perm filename ATC.LSP[MRS,LSP]5 blob
sn#659295 filedate 1982-05-16 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00007 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 (DECLARE (fasload struct fas dsk (mac lsp))
C00030 00003 (DEFUN LT-TYPE (LT-FORM)
C00051 00004 (DEFMACRO PRINCLIST (PRINTLIST)
C00062 00005 (SETQ YHπ-FLAG NIL)
C00103 00006
C00142 00007 (SETQ |cc-op: | '|cc-op: | |=>| '|=>| | .| '| .| | | '| | | | '| |)
C00167 ENDMK
C⊗;
(DECLARE (fasload struct fas dsk (mac lsp))
; (*rset (nouuo t))
(mapex t)
(*lexpr λ-UNSUBST QV-QUASI-UNSUBST NORMALIZE-CMPD-CONCEPT
ANALYZE-CMPD-CONCEPT NRML-ANL-YZE-LINFORMULA )
(load '|nsublis.lsp|) ;; NOTE : This file must contain up-to-date
;; copies of all *DEFUN definitions in both NWREP and DNET.
(special QV-SUBSTLIST UQ-LIST CURRENTPOS SUBSTLISTPTR GENVARINDEX
GENVAR-RANGES BREAK-POINTS BREAK-BEFORE-POINTS *CONCEPTS*
ALPHABET REVERSE-ALPHABET ALPHA-NCONSES *NOPOINT
↑-MATRIX-ANALYSIS-LIST JUNCT-ANALYSIS-LIST ANALYSIS-LIST
SUBSTPAIRS TERMCOPIES SUBSTPAIR *-ASCII AL-VARS RO-INDEX
CURRENTNODE CURRENT-NODE-PATH VERBOSITY XPDN-HELP-TABLE
YHπ-FLAG )
(special |cc-op: | |=>| | .| | | | ;| V C | | | - | ) )
(SETQ IBASE 10. BASE 10.)
(SETQ PRINLEVEL 3.)
(SETQ PRINLENGTH 60.)
(LINEL NIL 80)
(SETQ BREAK-POINTS '(|, | | ∧ | | ∨ |) ;; possibly also /:
BREAK-BEFORE-POINTS '(|↑[|) )
(DEFSTRUCT (↑↓-TERM (TYPE TREE))
↑↓-MARKER ↑↓-MATRIX )
(DEFSTRUCT (LT-QUANTIFIER (TYPE HUNK) (CONC-NAME LT-))
DEPENDENCIES DETERMINER QSORTEXPR SCOPE )
(DEFSTRUCT (ROLELINK (TYPE TREE))
ROLEMARK ARGUMENT )
(DEFSTRUCT (PFC-FORMULA (TYPE TREE))
PFC-CONCEPT ROLELINKS )
; PFC-FORMULA => (pred rlnk1 rlnk2 ... rlnkn) or (func rlnk1 rlnk2 ... rlnkn)
; or (connective rlnk1 rlnk2 ... rlnkn)
(DEFSTRUCT (ROLEXENTRY (TYPE TREE))
ROLENAME ROLEPHRASE )
(DEFSTRUCT (LT-λ-EXPR (TYPE TREE) (CONC-NAME LT-))
(λ-PREFIX (MAKE-LT-λ-PREFIX)) λ-SCOPE )
(DEFSTRUCT (LT-λ-PREFIX (TYPE TREE) (BUT-FIRST LT-λ-PREFIX) (CONC-NAME LT-))
(λ-MARK 'λ) PATHKEYLISTS )
; PATHKEYLISTS => ((<termsort> <pathkey> {<pathkey>} ... ) ... )
(DEFSTRUCT (PATHKEYLIST (TYPE TREE))
λ-TERMSORT PATHKEYS )
(DEFMACRO ANTECEDENT (LT-⊃-PROPO)
`(ARGUMENT (ASSQ 'ANTECEDENT (ROLELINKS ,LT-⊃-PROPO))) )
(DEFMACRO CONSEQUENT (LT-⊃-PROPO)
`(ARGUMENT (ASSQ 'CONSEQUENT (ROLELINKS ,LT-⊃-PROPO))) )
(DEFMACRO CONSP (EXPR)
`(EQ (TYPEP ,EXPR) 'LIST) )
(DEFMACRO *DEFUN ((F-TYPE . F-NAME) ARGLIST . BODY)
`(PROGN
(PUTPROP (OR (GET ',F-NAME 'FUNCTIONS)
(PUTPROP ',F-NAME (NCONS "*DEFUN-PLIST") 'FUNCTIONS))
,(COND ((EQ (CAR BODY) '*SYN) `',(CADR BODY))
(T `'(LAMBDA ,ARGLIST ,@BODY)) )
',F-TYPE )
(LET ((OLDMACRO (GET ',F-TYPE 'MACRO))
(NEWMACRO '(LAMBDA (FORM)
`(GET (GET ',(CDR FORM) 'FUNCTIONS) ',',F-TYPE) )) )
(COND ((AND OLDMACRO
(NOT (EQUAL OLDMACRO NEWMACRO)) )
(TERPRI) (PRINC "Macro ") (PRIN1 ',F-TYPE)
(PRINC " already defined differently!")
(BREAK *DEFUN) )) )
(DEFUN ,F-TYPE MACRO (FORM)
`(GET (GET ',(CDR FORM) 'FUNCTIONS) ',',F-TYPE) ) ) )
(*DEFUN (ISA . COREROLE) (ROLEMARK LT-FORM)
(MEMQ ROLEMARK (GET (PFC-CONCEPT LT-FORM) 'COREROLES)) )
(*DEFUN (THE-FOR:ROLELINK . ROLEPHRASE) (ROLELINK LT-FORM)
(CDR (ASSQ (ROLEMARK ROLELINK) (GET (PFC-CONCEPT LT-FORM) 'ROLEXICON))) )
(*DEFUN (THE-OF:LT-QUANT . QSORT) (LT-QUANT)
(LET* ((QSORTEXPR (LT-QSORTEXPR LT-QUANT))
(ATOMICQSORTEXPR
(CASEQ (LT-TYPE QSORTEXPR)
(ATOMICPROPO QSORTEXPR)
(CONJ-PROPO (ARGUMENT (CAR (ROLELINKS QSORTEXPR)))) ) ) )
(COND ((EQ (PFC-CONCEPT ATOMICQSORTEXPR) 'CONCEPT)
(NORMALIZE-TERMSORTEXPR
(CONS '↑ (TERMSORT
(ARGUMENT
(ASSQ 'OBJECT
(ROLELINKS ATOMICQSORTEXPR) ) ) )) ) )
(T (PFC-CONCEPT ATOMICQSORTEXPR)) )) )
(*DEFUN (THE-OF:LT-QUANT . DETERMINER) (LT-QUANT)
*SYN CAR )
; *SYN LT-DETERMINER ) This usage causes an "; IMPROPER USE OF MACRO - EVAL"
; error message; what LISP doesn't like here is simply the fact that
; LT-DETERMINER is a macro.
(*DEFUN (THE-OF:LT-λ-PREFIX . PATHKEYLISTS) (λ-PREFIX)
*SYN CDR )
(*DEFUN (THE-OF:LT-QUANT . QSORTEXPR) (LT-QUANTIFIER)
(CXR 2 LT-QUANTIFIER) )
(*DEFUN (THE-OF:LT-QUANT . SCOPE) (LT-QUANTIFIER)
(CXR 3 LT-QUANTIFIER) )
(*DEFUN (THE-OF:LINQUANT . DETERMINER) (LINQUANT)
(CAR LINQUANT) )
(*DEFUN (ISA-OF:LT . λ-EXPR) (LT-FORM)
(AND (CONSP LT-FORM) (CONSP (CAR LT-FORM)) (MEMQ (CAAR LT-FORM) '(λ LAMBDA))) )
; λ-pair: (<λ-mark> . <termsort-indicator>)
; λ-mark: λ
; termsort-indicator: either <termsort-atom> or (<↑-marker> . <termsort-atom>)
; ↑-marker: either ↑ or ↑n , n being a digit such that 2≤n≤9.
(*DEFUN (ISA . λ-PAIR) (LT-FORM)
(AND (CONSP LT-FORM)
(EQ 'λ (CAR LT-FORM))
(OR (SYMBOLP (CDR LT-FORM))
(AND (SYMBOLP (CADR LT-FORM))
(EQ '↑ (GETCHAR (CADR LT-FORM) 1)) ) ) ) )
(*DEFUN (ISA . PATT-VARIABLE) (LT-FORM)
(AND (SYMBOLP LT-FORM)
(MEMQ (GETCHAR LT-FORM 1) '(? *)) ) )
(*DEFUN (ISA . BREAK-BEFORE-POINT) (PRINTATOM)
(AND (SYMBOLP PRINTATOM)
(EQ '↑ (GETCHAR PRINTATOM 1))
(OR (EQ '/[ (GETCHAR PRINTATOM 2))
(EQ '/[ (GETCHAR PRINTATOM 3)) ) ) )
; (EQ '/[ (CAR (LAST (EXPLODE PRINATOM)))) ) ) ;; too much consing
(*DEFUN (ISA . BREAK-POINT) (PRINTATOM)
(MEMQ PRINTATOM BREAK-POINTS) )
(*DEFUN (ISA . ROLELINK) (LT-FORM)
(AND (CONSP LT-FORM) (EQ (GET (CAR LT-FORM) 'CATEGORY) 'ROLEMARK)) )
(*DEFUN (ISA-OF:LIN . QUANTIFIER) (LINFORM)
(EQ (GET (CAR LINFORM) 'CATEGORY) 'DETERMINER) )
(*DEFUN (ISA-OF:LT . QUANTIFIER) (LT-FORM)
(EQ (GET (#.(THE-OF:LT-QUANT . DETERMINER) LT-FORM) 'CATEGORY) 'DETERMINER) )
(DEFMACRO LAMBDA-OPR (OBJ)
`(MEMQ (CAAR ,OBJ) '(LAMBDA λ)) )
(DEFMACRO E:DO (STRING)
`(EM:ECOMMANDS (EXPLODEC ,STRING)) )
(DEFMACRO E:VAR (VARNAME)
`(CDAR (EM:READONLY-VARS '(,VARNAME))) )
(DEFUN E:SETLINE (NUMBER)
(LET ((CHAR-LIST))
(SETQ *NOPOINT T)
(SETQ CHAR-LIST (APPEND (MAPCAN #'(LAMBDA (P D) (LIST P D))
'(α α α α α)
(EXPLODEC NUMBER) )
'(α L) ))
(SETQ *NOPOINT NIL)
(EM:ECOMMANDS CHAR-LIST) ) )
(DEFMACRO ADDCONC (ADDLIST BASELISTATOM)
`(SETQ ,BASELISTATOM (NCONC ,ADDLIST ,BASELISTATOM)) )
(DEFMACRO ENDCONC (ADDLIST BASELISTATOM)
`(COND (,BASELISTATOM (NCONC ,BASELISTATOM ,ADDLIST))
(T (SETQ ,BASELISTATOM ,ADDLIST)) ) )
(DEFMACRO ENDADD (ADDITEM BASELISTATOM)
`(COND (,BASELISTATOM (NCONC ,BASELISTATOM (NCONS ,ADDITEM)))
(T (SETQ ,BASELISTATOM (NCONS ,ADDITEM))) ) )
(DEFMACRO RASSQ (KEY A-LIST)
`(DO ((A-TAIL ,A-LIST (CDR A-TAIL)))
((NULL A-TAIL))
(COND ((EQ (CDAR A-TAIL) ,KEY) (RETURN (CAR A-TAIL)))) ) )
(DEFMACRO EDITXDO (EXPR &rest BODY)
`(PROGN (EDIT1 ,EXPR) .
,(MAPCAR '(LAMBDA (CMD) `(%EVALUATE ',CMD)) BODY) ) )
(DEFMACRO EDITDO (&rest BODY)
`(PROGN . ,(MAPCAR '(LAMBDA (CMD) `(%EVALUATE ',CMD)) BODY) ) )
(DEFMACRO COPYLIST (LIST)
`(APPEND ,LIST NIL) )
(DEFMACRO BUTLAST (LIST)
`(NREVERSE (CDR (REVERSE ,LIST))) )
(DEFMACRO REPEAT (NUMBER FORM)
`(DO ((TALLY ,NUMBER (1- TALLY)))
((ZEROP TALLY))
,FORM ) )
(DEFMACRO SETF* (SETFORM VALUEFORM)
(LIST 'SETF SETFORM (NSUBLIS `((-*- . ,SETFORM)) VALUEFORM)) )
(DEFMACRO SOME (LIST PREDICATE . &opt:STEP-FUNCTION)
(SETF* PREDICATE (EVAL -*-))
(COND (&opt:STEP-FUNCTION (SETF* &opt:STEP-FUNCTION (EVAL -*-))))
`(DO ((LISTAIL ,LIST (,(COND (&opt:STEP-FUNCTION
(CAR &opt:STEP-FUNCTION) )
(T 'CDR) )
LISTAIL )))
((NULL LISTAIL) NIL)
(COND ((,PREDICATE (CAR LISTAIL)) (RETURN LISTAIL))) ) )
(DEFMACRO SUBSET (PREDICATE LIST)
(SETF* PREDICATE (EVAL -*-))
`(MAPCAN #'(LAMBDA (MEMBER)
(COND ((,PREDICATE MEMBER) (NCONS MEMBER))) )
,LIST ) )
(DEFUN GOOD-NREVERSE (LIST)
(COND ((OR (NULL LIST) (NULL (CDR LIST))) LIST)
((OR (NULL (CDDR LIST)) (NULL (CDDDR LIST)))
(LET ((REMEM (CAR (LAST LIST))))
(RPLACA (LAST LIST) (CAR LIST))
(RPLACA LIST REMEM) ) )
(T (PROG (TRAILER POINTER LEADER)
(SETQ TRAILER (CDR LIST)
POINTER (CDR TRAILER)
LEADER (CDR POINTER) )
RPT (RPLACD POINTER TRAILER)
(COND ((CDR LEADER) (SETQ TRAILER POINTER
POINTER LEADER
LEADER (CDR LEADER) )
(GO RPT) ))
(RPLACD (CDR LIST) LEADER)
(RPLACD LIST POINTER)
(SETQ TRAILER (CAR LEADER))
(RPLACA LEADER (CAR LIST))
(RETURN (RPLACA LIST TRAILER)) ) ) ) )
(DEFUN NSUBLIS (A-LIST S-EXPR &aux SUBSTPAIR)
(COND ((CONSP S-EXPR)
(COND ((CONSP (CAR S-EXPR)) (NSUBLIS A-LIST (CAR S-EXPR)))
((SETQ SUBSTPAIR (ASSQ (CAR S-EXPR) A-LIST))
(RPLACA S-EXPR (CDR SUBSTPAIR)) ) )
(COND ((CONSP (CDR S-EXPR)) (NSUBLIS A-LIST (CDR S-EXPR)))
((SETQ SUBSTPAIR (ASSQ (CDR S-EXPR) A-LIST))
(RPLACD S-EXPR (CDR SUBSTPAIR)) ) )
S-EXPR )
((COND ((SETQ SUBSTPAIR (ASSQ S-EXPR A-LIST)) (CDR SUBSTPAIR))
(S-EXPR) )) ) )
(DEFMACRO HUNKQUANTP (LT-FORM)
`(AND (HUNKP ,LT-FORM) (#.(ISA-OF:LT . QUANTIFIER) ,LT-FORM)) )
(DEFUN QNSUBLIS (A-LIST S-EXPR)
(COND ((CONSP S-EXPR)
(COND ((CONSP (CAR S-EXPR)) (QNSUBLIS A-LIST (CAR S-EXPR))))
(COND ((OR (CONSP (CDR S-EXPR)) (HUNKQUANTP (CDR S-EXPR)))
(QNSUBLIS A-LIST (CDR S-EXPR)) )
((ATOM (CDR S-EXPR))
(LET ((SUBSTPAIR (ASSQ (CDR S-EXPR) A-LIST)))
(COND (SUBSTPAIR (RPLACD S-EXPR (CDR SUBSTPAIR)))) ) ) )
S-EXPR )
((HUNKQUANTP S-EXPR)
(QNSUBLIS A-LIST (LT-QSORTEXPR S-EXPR))
(QNSUBLIS A-LIST (LT-SCOPE S-EXPR))
S-EXPR )
((ATOM S-EXPR) S-EXPR)
(T (BREAK "QNSUBLIS - unrecognized type of S-EXPR.")) ) )
(DEFMACRO CONDCARPUSH (PREDEXPR PUSHEXPR STACKEXPR)
(SETQ PUSHEXPR (NSUBLIS `((-*- . ,PREDEXPR)) PUSHEXPR))
(SETQ STACKEXPR (NSUBLIS `((-*- . ,PREDEXPR)) STACKEXPR))
`(COND (,PREDEXPR (CAR (PUSH ,PUSHEXPR ,STACKEXPR)))
(T ,PUSHEXPR) ) )
(DEFMACRO WRITE BODY
`(PROGN ,@(MAPCAR #'(LAMBDA (X)
(COND ((EQ X 'T) '(TERPRI))
((ATOM X) `(PRINC ,X))
((AND (CONSP X)
(MEMQ (CAR X) '(SPACES DISPLAY POSPRINC
GO TAB BREAK ERROR )) )
X )
((AND (CONSP X)
(EQ '* (CAR X)) )
`(PRINC ,(CDR X)) )
(T `(PRIN1 ,X)) ) )
BODY ) ) )
(DEFUN SPACES (N)
(DO ((TALLY N (1- TALLY)))
((ZEROP TALLY) T)
(PRINC '/ ) ) )
(DEFMACRO NORMALIZE-CONNECTIVE (CONN)
`(CASEQ ,CONN
((∧ & AND) '∧)
((∨ OR) '∨)
((¬ ~ NOT) '¬)
((⊃ M-ONLYIF) '⊃)
(T (WRITE T "; unrecognized connective: " ,CONN
(BREAK NORMALIZE-CONNECTIVE) )) ) )
(DEFUN LINTYPE (LISPINPUTFORM)
(COND ((NULL LISPINPUTFORM) (BREAK "LINTYPE - null input form!"))
((ATOM LISPINPUTFORM) 'SIMPLETERM)
((NOT (CONSP LISPINPUTFORM))
(WRITE T "; unexpected input form: " LISPINPUTFORM
(BREAK LINTYPE) ) )
((ATOM (CAR LISPINPUTFORM))
(COND ((MEMQ (GET (CAR LISPINPUTFORM) 'CATEGORY)
'(ATTRIBUTE ACT-ATTRIBUTE COUNT-SORT CATEGORY SORT) )
'ATOMICPROPO )
((EQ (GET (CAR LISPINPUTFORM) 'CATEGORY) 'FUNCTION)
'F-TERM )
((FIXP (CAR LISPINPUTFORM)) 'FIXNUM-VECTOR)
((EQ (GET (GETCHAR (CAR LISPINPUTFORM) 1) 'CATEGORY)
'SYNTACTIC-MARKER )
'↑↓-TERM )
((EQ (GET (NORMALIZE-CONNECTIVE (CAR LISPINPUTFORM)) 'CATEGORY)
'CONNECTIVE )
'CONNPROPO )
(T (WRITE T "; unrecognized input form: " LISPINPUTFORM
(BREAK LINTYPE) )) ) )
(T (COND ((EQ (GET (#.(THE-OF:LINQUANT . DETERMINER) (CAR LISPINPUTFORM))
'CATEGORY )
'DETERMINER ) 'QUANTPROPO)
((EQ (GET (#.(THE-OF:LINQUANT . DETERMINER) (CAR LISPINPUTFORM))
'CATEGORY )
'LAMBDA-DETERMINER ) 'λ-EXPR)
(T (WRITE T "; unrecognized input form: " LISPINPUTFORM
(BREAK LINTYPE) )) )) ) )
(DEFUN ENCODE-LINFORMULA (FORM &aux QV-SUBSTLIST)
(LET ((ENCODED-LINFORMULA-S (ENCODE-LINFORMULA-S FORM NIL)))
(QNSUBLIS QV-SUBSTLIST ENCODED-LINFORMULA-S) ) )
(DEFMACRO SETUPQUANTS (QUANTLIST NEWMATRIX)
`(DO ((QUANTAIL ,QUANTLIST (CDR QUANTAIL)))
((NULL (CDR QUANTAIL))
(PUSH (CONS (LT-SCOPE (CAR QUANTAIL)) (CAR QUANTAIL)) QV-SUBSTLIST)
;; QV-SUBSTLIST: ((<variable> . <quantifier>) ...)
(SETF (LT-SCOPE (CAR QUANTAIL)) ,NEWMATRIX) )
(PUSH (CONS (LT-SCOPE (CAR QUANTAIL)) (CAR QUANTAIL)) QV-SUBSTLIST)
(SETF (LT-SCOPE (CAR QUANTAIL)) (CADR QUANTAIL)) ) )
(DEFMACRO ORDER-PATHKEYS (PATHKEYLIST)
`(SORT ,PATHKEYLIST #'ALPHALESSP) )
; ENCODE-LINFORMULA-S uses the variable QV-SUBSTLIST freely.
(DEFUN ENCODE-LINFORMULA-S (FORM UQ-LIST)
;; UQ-LIST is used to record quantifier dependencies
(CASEQ (LINTYPE FORM)
((ATOMICPROPO F-TERM)
(TRANSFORM-ROLELINKS FORM)
(MAPC #'(LAMBDA (RLNK)
(SETF* (ARGUMENT RLNK) (ENCODE-LINFORMULA-S -*- UQ-LIST)) )
(ROLELINKS FORM))
(SETF (ROLELINKS FORM) (ORDER-ROLELINKS FORM))
FORM )
(CONNPROPO
(RPLACA FORM (NORMALIZE-CONNECTIVE (CAR FORM)))
(TRANSFORM-ROLELINKS FORM)
(MAPC #'(LAMBDA (RLNK)
(SETF* (ARGUMENT RLNK) (ENCODE-LINFORMULA-S -*- UQ-LIST)) )
(ROLELINKS FORM) )
FORM )
(QUANTPROPO
(LET ((QUANTLIST (MAPCAN (FUNCTION ENCODE-QUANT) (BUTLAST FORM)))
(NEWMATRIX (ENCODE-LINFORMULA-S (CAR (LAST FORM)) UQ-LIST)) )
(SETUPQUANTS QUANTLIST NEWMATRIX)
(CAR QUANTLIST) ) )
((SIMPLETERM FIXNUM-VECTOR)
FORM)
(↑↓-TERM
(RPLACD FORM (CADR FORM))
(SETF* (↑↓-MATRIX FORM) (ENCODE-LINFORMULA-S -*- UQ-LIST))
FORM )
(λ-EXPR
(RPLACD FORM (ENCODE-LINFORMULA-S (CADR FORM) UQ-LIST))
(MAP #'(LAMBDA (VARLISTAIL)
(LET ((PKEYLIST
(MAKE-PATHKEYLIST PATHKEYS
(ORDER-PATHKEYS
(MAPCAR #'IMPLODE
(QV-QUASI-UNSUBST
(CAR VARLISTAIL)
(LT-λ-SCOPE FORM) ) ) ) ) ))
(ADJUST-λ-TERMSORT PKEYLIST FORM)
(SETF (CAR VARLISTAIL) PKEYLIST) ) )
(CDAR FORM) )
(SETF* (LT-PATHKEYLISTS FORM) (ORDER-PATHKEYLISTS -*-))
(λ-UNSUBST FORM NIL) )
(T (BREAK "ENCODE-LINFORMULA-S - unrecognized formula type.")) ) )
; TRANSFORM-ROLELINKS needs to be generalized to deal with the case in which
; a pfc-formula has variably many identical coreroles, and also several
; different non-core role arguments.
; (TRANSFORM-ROLELINKS <pfc-formula>)
(DEFUN TRANSFORM-ROLELINKS (PFC-FORM &aux VARGFLAG)
(COND ((EQ (GET (PFC-CONCEPT PFC-FORM) 'COREROLE-NUMBER) 'VARIABLE)
(SETQ VARGFLAG T) ))
(DO ((R-LINKS (ROLELINKS PFC-FORM) (CDR R-LINKS))
(CR-MARKS (GET (PFC-CONCEPT PFC-FORM) 'COREROLES)
(COND (VARGFLAG CR-MARKS) (T (CDR CR-MARKS))) ) )
((NULL R-LINKS))
(COND (CR-MARKS (RPLACA R-LINKS (MAKE-ROLELINK ROLEMARK (CAR CR-MARKS)
ARGUMENT (CAR R-LINKS) )))
(T (RPLACD (CAR R-LINKS) (CADAR R-LINKS))
(RPLACA (CAR R-LINKS)
(CAR (RASSQ (CAAR R-LINKS)
(GET (PFC-CONCEPT PFC-FORM)
'ROLEXICON ) )) ) ) ) ) )
(DEFMACRO NORMALIZE-DETERMINER (DET)
`(CASEQ ,DET
((∀ ALL EVERY) '∀)
((∃ SOME EXIST) '∃)
((the) 'the)
((!1) '!1)
(T (WRITE T "; unrecognized determiner: " ,DET
(BREAK NORMALIZE-DETERMINER) )) ) )
;; ENCODE-QUANT accesses and updates the freevar UQ-LIST
(DEFUN ENCODE-QUANT (QUANT &aux VAR-RANGE QSORTEXP)
(DO ((DET (CAR QUANT))
(VS-PAIRS (CDR QUANT) (CDDR VS-PAIRS))
;; vs-pairs: (<variable> <qsortexpr> ...1 ...2 )
(DEPS (COND ((EQ (NORMALIZE-DETERMINER (CAR QUANT)) '∃) UQ-LIST)))
(QLIST) )
((NULL VS-PAIRS) (GOOD-NREVERSE QLIST)
(COND ((EQ (NORMALIZE-DETERMINER DET) '∀)
(COND (UQ-LIST (NCONC UQ-LIST (COPYLIST QLIST)))
(T (SETQ UQ-LIST (COPYLIST QLIST))) ) ))
QLIST )
(SETQ VAR-RANGE (VARIABLE-RANGE (CAR VS-PAIRS)))
(SETQ QSORTEXP (COND ((ATOM (CADR VS-PAIRS))
(LIST (CADR VS-PAIRS) (CAR VS-PAIRS)) )
(T (CADR VS-PAIRS)) ))
(ENCODE-LINFORMULA-S QSORTEXP UQ-LIST)
(PUSH (MAKE-LT-QUANTIFIER
DETERMINER (NORMALIZE-DETERMINER DET)
QSORTEXPR QSORTEXP
SCOPE (CAR VS-PAIRS) ; variable here temporarily
DEPENDENCIES DEPS )
QLIST ) ) )
(DEFUN VARIABLE-RANGE (VARIABLE &aux ↑-MARK)
(SETQ VARIABLE (EXPLODEC VARIABLE))
(COND ((MEMQ '↑ VARIABLE)
(SETQ ↑-MARK (IMPLODE (NREVERSE (MEMQ '↑ (REVERSE VARIABLE)))))
(SETQ VARIABLE (CDR (MEMQ '↑ VARIABLE))) ) )
(SETQ VARIABLE (IMPLODE VARIABLE))
(COND (↑-MARK (CONS ↑-MARK (GET VARIABLE 'RANGE)))
(T (GET VARIABLE 'RANGE)) ) )
(DEFUN GETFORMULA (SOURCE)
(COND ((EQ SOURCE 'TTY) (WRITE T "LISP-form input, please: ")
(PROG1 (READ) (WRITE T "Thank you. ")) )
(T (BREAK "GETFORMULA - unrecognized input source.")) ) )
(DEFMACRO ATC-GET (GENL-PLIST INDICATOR)
`(LET ((GENL-PLIST ,GENL-PLIST))
(COND ((AND YHπ-FLAG (π-YH-UNITP GENL-PLIST))
(π-GET GENL-PLIST ,INDICATOR) )
(T (GET GENL-PLIST ,INDICATOR)) ) ) )
; An alternative, less efficient definition of ATC-GET
;(DEFMACRO ATC-GET (GENL-PLIST INDICATOR)
; `(LET ((GENL-PLIST ,GENL-PLIST))
; (COND ((OR (AND (CONSP GENL-PLIST) (EQ '*CC-PLIST* (CAR GENL-PLIST)))
; (AND YHπ-FLAG (NOT (π-YH-UNITP GENL-PLIST))) )
; (GET GENL-PLIST ,INDICATOR) )
; (T (π-GET GENL-PLIST ,INDICATOR)) ) ) )
(DEFMACRO ATC-PLIST (GENL-PLIST)
`(COND ((OR (AND (CONSP ,GENL-PLIST) (EQ '*CC-PLIST* (CAR ,GENL-PLIST)))
(AND YHπ-FLAG (NOT (π-YH-UNITP ,GENL-PLIST))) )
(PLIST ,GENL-PLIST) )
(T (π-PLIST ,GENL-PLIST)) ) )
(DEFUN LT-TYPE (LT-FORM)
(COND ((NULL LT-FORM) (WRITE T "; LT-FORM is null!" (BREAK LT-TYPE)))
((AND (SYMBOLP LT-FORM)
(MEMQ (GETCHAR LT-FORM 1) '(? *)) )
'PATT-VARIABLE )
((ATOM LT-FORM) 'SIMPLEFORM)
((#.(ISA-OF:LT . QUANTIFIER) LT-FORM) 'QUANTIFIERFORM)
((NOT (CONSP LT-FORM)) (WRITE T "; LT-form " LT-FORM
" is unacceptable!" (BREAK LT-TYPE:ua1) ))
((ATOM (CAR LT-FORM))
(CASEQ (GET (CAR LT-FORM) 'CATEGORY)
((ATTRIBUTE ACT-ATTRIBUTE COUNT-SORT CATEGORY SORT) 'ATOMICPROPO)
(FUNCTION 'F-TERM)
(CONNECTIVE
(CASEQ (CAR LT-FORM)
((¬ NOT ~) 'NEGPROPO)
((∧ AND &) 'CONJ-PROPO)
((∨ OR) 'DISJ-PROPO)
((⊃ M-ONLYIF) '⊃-PROPO)
(T (BREAK "LT-TYPE - unacceptable connective!")) ) )
(ROLEMARK 'ROLELINK)
(T (COND ((FIXP (CAR LT-FORM)) 'FIXNUM-VECTOR)
((CASEQ (GETCHAR (CAR LT-FORM) 1)
(↑ '↑-TERM)
(↓ '↓-TERM)
(T NIL) ))
((MEMQ (CAR LT-FORM) '(λ LAMBDA)) 'λ-PAIR)
(T (BREAK "LT-TYPE - unrecognized type:1")) )) ) )
((MEMQ (CAAR LT-FORM) '(λ LAMBDA)) 'λ-EXPR)
((NOT (HUNKP (CAR LT-FORM)))
(WRITE T "; LT-FORM: " LT-FORM " is unacceptable!"
(BREAK LT-TYPE:ua2) ) )
(T (BREAK "LT-TYPE - unrecognized type:2")) ) )
(DEFUN DISPLAY (LT-FORM &optional (CURRENTPOS 1)) ;; CURRENTPOS used freely by
(SETQ *NOPOINT T)
(STRAIGHTPRIN (DPYLIST LT-FORM)) ;; lower level print functions
(SETQ *NOPOINT NIL)
CURRENTPOS )
(DEFUN DPYLIST (LT-FORM &aux (SUBSTLISTPTR (NCONS NIL))
(DPYLIST-SUBST (DPYLIST-S LT-FORM)) )
(COND ((CAR SUBSTLISTPTR)
(VNSUBLIS (MAKE-QVLIST (CAR SUBSTLISTPTR)) DPYLIST-SUBST))
(T DPYLIST-SUBST) ) )
(DEFUN VNSUBLIS (A-LIST DPYLIST)
; (PRINT DPYLIST) (break vnsublis:test)
(DO ((DPYTAIL DPYLIST (CDR DPYTAIL))
(QV-PAIR) )
((NULL DPYTAIL) DPYLIST)
(COND ((AND (NOT (ATOM (CAR DPYTAIL)))
(SETQ QV-PAIR (ASSQ (CAR DPYTAIL) A-LIST)) )
(RPLACA DPYTAIL (CDR QV-PAIR)) ) ) ) )
(DEFMACRO INITIALIZE-GENVARINDEX ()
`(MAPC (FUNCTION (LAMBDA (RANGENTRY)
(RPLACA (CDR RANGENTRY) (CAADDR RANGENTRY))
(MAPC (FUNCTION (LAMBDA (VPAIR)
(RPLACD VPAIR 0) ))
(CDDR RANGENTRY) ) ))
GENVARINDEX ) )
; GENVAR accesses and updates the global variable GENVARINDEX
(DEFUN GENVAR (VARANGE &optional INITFLAG
;; VARANGE : either <varsort-atom> or (<↑-mark> . <varsort-atom>)
&aux VARLIST CURRENTBASEVAR CURRENTVAR ↑-MARK)
(COND (INITFLAG (INITIALIZE-GENVARINDEX))
(T (COND ((CONSP VARANGE)
(SETQ ↑-MARK (CAR VARANGE)
VARANGE (CDR VARANGE) ) ) )
(SETQ VARLIST (CDR (ASSQ VARANGE GENVARINDEX))
CURRENTBASEVAR (CAR VARLIST)
CURRENTVAR (ASSQ CURRENTBASEVAR (CDR VARLIST)) )
;; varlist: (currentbasevar (basevar . current-subscript) ...)
(OR VARLIST (WRITE T "; no entry for variable-sort: " VARANGE
" in GENVARINDEX." (BREAK GENVAR) ))
(PROG1 (COND ((AND (NULL ↑-MARK) (= 0 (CDR CURRENTVAR)))
CURRENTBASEVAR )
(T (IMPLODE `(,@(COND (↑-MARK (EXPLODE ↑-MARK)))
,CURRENTBASEVAR
,@(COND
((= 0 (CDR CURRENTVAR)) NIL)
(T (NCONS (+ 48. (CDR CURRENTVAR))))
) ))) )
(RPLACD CURRENTVAR (1+ (CDR CURRENTVAR)))
(RPLACA VARLIST
(COND ((CAADR (MEMQ CURRENTVAR (CDR VARLIST))))
(T (CAADR VARLIST)) ) ) ) ) ) )
(DEFMACRO TERMSORT-VARANGE (TERMFORM)
`(LET* ((TERMFORM ,TERMFORM)
(TERMSORT
(COND ((#.(ISA-OF:LT . QUANTIFIER) TERMFORM)
(#.(THE-OF:LT-QUANT . QSORT) TERMFORM) )
((#.(ISA . λ-PAIR) TERMFORM)
(CDR TERMFORM) )
(T (BREAK "TERMSORT-VARANGE - unrecognized termform type.")) )) )
(OR TERMSORT (WRITE T "; Null termsort for " TERMFORM
(BREAK TERMSORT-VARANGE) ))
(LET* ((↑-MARKER (COND ((CONSP TERMSORT) (CAR TERMSORT))))
(BASE-RANGE (COND ((CONSP TERMSORT) (CDR TERMSORT))
(T TERMSORT) ))
(BASE-VARANGE
(DO ((VARANGE? BASE-RANGE
(OR (GET VARANGE? 'SUPERSORT)
(WRITE T "; No supersort for " VARANGE?
(BREAK TERMSORT-VARANGE) ) ) ))
((MEMQ VARANGE? GENVAR-RANGES) VARANGE?) ) ) )
(COND (↑-MARKER (CONS ↑-MARKER BASE-VARANGE))
(T BASE-VARANGE) ) ) ) )
(DEFUN MAKE-QVLIST (SUBSTLIST)
(GENVAR NIL T)
(MAP #'(LAMBDA (SUBST-TAIL)
(RPLACA SUBST-TAIL
(CONS (CAR SUBST-TAIL)
(GENVAR (TERMSORT-VARANGE (CAR SUBST-TAIL))) ) ) )
SUBSTLIST ) )
(SETQ GENVARINDEX '((TIME T (T . 0))
(LOCATION L (L . 0))
(AFFAIRSTATE S (S . 0))
(PERSON P (P . 0))
(THING V (V . 0) (W . 0))
(NUMBER N (N . 0) (M . 0) (J . 0))
(PHYSOB X (X . 0) (Y . 0) (Z . 0))
(ATTRIBUTE A (A . 0)) ))
(SETQ GENVAR-RANGES (MAPCAR #'CAR GENVARINDEX))
(DEFMACRO UNARY-ATOMIC (LT-FORM)
`(AND (EQ (LT-TYPE ,LT-FORM) 'ATOMICPROPO)
(= 1 (LENGTH (ROLELINKS ,LT-FORM))) ) )
(DEFMACRO NOPAREN-DISJUNCT ()
`(OR (MEMQ ARGTYPE '(ATOMICPROPO SIMPLEFORM NEGPROPO))
(AND (EQ ARGTYPE 'CONJ-PROPO)
(> 3 (LENGTH (ROLELINKS LT-FORM)))
;;?(EACH CONJUCT (MEMQ ARGTYPE '(ATOMICPROPO SIMPLEFORM NEGPROPO)))
) ) )
(DEFMACRO DPYLIST-ROLINK (ROLINK LT-FORM)
`(NCONC (COND ((NOT (#.(ISA . COREROLE) (ROLEMARK ,ROLINK) ,LT-FORM))
(LIST (#.(THE-FOR:ROLELINK . ROLEPHRASE) ,ROLINK ,LT-FORM)
'/: ) ))
(DPYLIST-S (ARGUMENT ,ROLINK)) ) )
(DEFMACRO MAKE-↑↓-/[-ATOM (↑↓-MARKER)
`(IMPLODE (NCONC (EXPLODE ,↑↓-MARKER) '(/[))) )
; DPYLIST-S updates the freevar SUBSTLISTPTR
(DEFUN DPYLIST-S (LT-FORM)
(CASEQ (LT-TYPE LT-FORM)
(ATOMICPROPO
(*CATCH '|=PROPO|
(COND ((EQ '= (CAR LT-FORM))
(*THROW '|=PROPO|
(LET* ((ROLINKS (ROLELINKS LT-FORM))
(ARG1 (ARGUMENT (CAR ROLINKS)))
(ARG2 (ARGUMENT (CADR ROLINKS))) )
(NCONC (DPYLIST-S ARG1)
(NCONS '| = |)
(DPYLIST-S ARG2) ) ) ) ))
(LET ((PARENFLAG (COND ((< 1 (LENGTH (ROLELINKS LT-FORM))) T))))
(NCONC (LIST (PFC-CONCEPT LT-FORM))
(LIST (COND (PARENFLAG '/( ) (T '/ )))
(DO ((RL-LIST (ROLELINKS LT-FORM) (CDR RL-LIST))
(COMMAFLG NIL T)
(PRINTLISTPTR (NCONS NIL)) )
((NULL RL-LIST) (CAR PRINTLISTPTR))
(COND (COMMAFLG (TCONC '|, | PRINTLISTPTR)))
(LCONC (DPYLIST-ROLINK (CAR RL-LIST) LT-FORM) PRINTLISTPTR) )
(COND (PARENFLAG (LIST '/) ))) ) ) ) )
(F-TERM
(LET ((PARENFLAG (COND ((< 1 (LENGTH (ROLELINKS LT-FORM))) T))))
(NCONC (LIST (PFC-CONCEPT LT-FORM))
(LIST (COND (PARENFLAG '/( ) (T '/ )))
(DO ((RL-LIST (ROLELINKS LT-FORM) (CDR RL-LIST))
(COMMAFLG NIL T)
(PRINTLISTPTR (NCONS NIL)) )
((NULL RL-LIST) (CAR PRINTLISTPTR))
(COND (COMMAFLG (TCONC '|, | PRINTLISTPTR)))
(LCONC (DPYLIST-ROLINK (CAR RL-LIST) LT-FORM) PRINTLISTPTR) )
(COND (PARENFLAG (LIST '/) ))) ) ) )
((SIMPLEFORM λ-PAIR) (LIST LT-FORM))
(QUANTIFIERFORM
(COND ((MEMQ LT-FORM (CAR SUBSTLISTPTR)) (LIST LT-FORM))
;; a QUANTIFIERFORM on QUANTSUBSTLIST is a term;
;; otherwise, it's a proposition.
((DO ((THISFORM LT-FORM (#.(THE-OF:LT-QUANT . SCOPE) THISFORM))
(DETERMINER (#.(THE-OF:LT-QUANT . DETERMINER) LT-FORM))
(DETFLAG T NIL) (OUTLISTPTR (NCONS NIL)) )
((NOT (AND (#.(ISA-OF:LT . QUANTIFIER) THISFORM)
(EQ (#.(THE-OF:LT-QUANT . DETERMINER) THISFORM)
DETERMINER ) ))
(TCONC '/} OUTLISTPTR)
(LET* ((PERIODFLAG (NOT (EQ (LT-TYPE THISFORM)
'QUANTIFIERFORM )))
(OUTLIST
(CAR (LCONC (COND (PERIODFLAG
(CONS '/.
(DPYLIST-S THISFORM) ) )
(T (DPYLIST-S THISFORM)) )
OUTLISTPTR )) ) )
OUTLIST ) )
(COND (DETFLAG (LCONC (LIST '/{ DETERMINER) OUTLISTPTR)))
(TCONC THISFORM SUBSTLISTPTR)
(LCONC (LIST '$VAR$ THISFORM '/.) OUTLISTPTR)
(LCONC (COND ((UNARY-ATOMIC (LT-QSORTEXPR THISFORM))
(LIST (PFC-CONCEPT (LT-QSORTEXPR THISFORM))) )
(T (DPYLIST-S (LT-QSORTEXPR THISFORM))))
OUTLISTPTR ) )) ))
(λ-EXPR
(DO ((PK-TAIL (LT-PATHKEYLISTS LT-FORM) (CDR PK-TAIL))
;; PK-TAIL: ((<termsort> <pathkey1> <pathkey2> ...) ...)
(λ-SCOPE (LT-λ-SCOPE LT-FORM))
(PRINTLISTPTR (NCONS NIL))
(COMMAFLAG NIL T) (λ-PAIR-ROLINK) (λ-PAIR) )
((NULL PK-TAIL)
(TCONC '|).| PRINTLISTPTR)
(LCONC (DPYLIST-S λ-SCOPE) PRINTLISTPTR)
(CONS '|(λ| (CAR PRINTLISTPTR)) )
(SETQ λ-PAIR-ROLINK (GET-ROLELINK
(CAR (PATHKEYS (CAR PK-TAIL))) λ-SCOPE ))
(SETQ λ-PAIR (COND ((EQ 'FN-VECTOR-LINK (ROLEMARK λ-PAIR-ROLINK))
(NTH (Z-BASE-EQUIV (CADR λ-PAIR-ROLINK))
(CADDR λ-PAIR-ROLINK) ) )
(T (ARGUMENT λ-PAIR-ROLINK)) ))
(COND ((MEMQ (LT-TYPE λ-PAIR) '(↓-TERM ↑-TERM))
(SETF* λ-PAIR (↑↓-MATRIX -*-)) ) )
(LCONC (COND (COMMAFLAG (LIST '/, λ-PAIR)) (T (LIST λ-PAIR)))
PRINTLISTPTR )
(TCONC λ-PAIR SUBSTLISTPTR) ) )
(NEGPROPO
(LET* ((BODY (ARGUMENT (CAR (ROLELINKS LT-FORM))))
(ARGTYPE (LT-TYPE BODY))
(PARENFLAG (COND ((MEMQ ARGTYPE '(QUANTIFIERFORM SIMPLEFORM))
NIL )
((AND (EQ ARGTYPE 'ATOMICPROPO)
(NOT (EQ '= (CAR BODY))) )
NIL )
(T T) )) )
(NCONC (NCONS '/¬ )
(COND (PARENFLAG (NCONS '/( )))
(DPYLIST-S BODY)
(COND (PARENFLAG (NCONS '/) ))) ) ) )
(CONJ-PROPO
(DO ((RL-TAIL (ROLELINKS LT-FORM) (CDR RL-TAIL))
(CONNFLAG NIL T) (OUTLISTPTR (NCONS NIL)) )
((NULL RL-TAIL) (CAR OUTLISTPTR))
(LET* ((ARGTYPE (LT-TYPE (ARGUMENT (CAR RL-TAIL))))
(PARENFLAG (COND ((MEMQ ARGTYPE '(ATOMICPROPO
SIMPLEFORM
NEGPROPO) )
NIL ) (T T) )) )
(COND (CONNFLAG (TCONC '| ∧ | OUTLISTPTR)))
(COND (PARENFLAG (TCONC '/( OUTLISTPTR)))
(LCONC (DPYLIST-S (ARGUMENT (CAR RL-TAIL)))
OUTLISTPTR)
(COND (PARENFLAG (TCONC '/) OUTLISTPTR))) ) ) )
(DISJ-PROPO
(DO ((RL-TAIL (ROLELINKS LT-FORM) (CDR RL-TAIL))
(CONNFLAG NIL T) (OUTLISTPTR (NCONS NIL)) )
((NULL RL-TAIL) (CAR OUTLISTPTR))
(LET* ((DISJUNCT (ARGUMENT (CAR RL-TAIL)))
(ARGTYPE (LT-TYPE DISJUNCT))
(PARENFLAG (COND ((NOPAREN-DISJUNCT) NIL)
(T T) )) )
(COND (CONNFLAG (TCONC '| ∧ | OUTLISTPTR)))
(COND (PARENFLAG (TCONC '/( OUTLISTPTR)))
(LCONC (DPYLIST-S (ARGUMENT (CAR RL-TAIL)))
OUTLISTPTR)
(COND (PARENFLAG (TCONC '/) OUTLISTPTR))) ) ) )
(⊃-PROPO
(LET ((ANTE (ANTECEDENT LT-FORM))
(CONSE (CONSEQUENT LT-FORM)) )
(NCONC (NCONS '/( )
(DPYLIST-S ANTE)
(NCONS '| ⊃ |)
(DPYLIST-S CONSE)
(NCONS '/) ) ) ) )
((↑-TERM ↓-TERM)
(NCONC (LIST (MAKE-↑↓-/[-ATOM (↑↓-MARKER LT-FORM)))
;; ↑↓-/[-atom: |↑[|, |↓[|, |↑2[|, |↑3[|, etc.
;; STRAIGHTPRIN may want the ↑↓-marker and leftbracket merged.
(DPYLIST-S (↑↓-MATRIX LT-FORM))
(LIST '/] ) ) )
(FIXNUM-VECTOR
(NCONC (LIST '/( (CAR LT-FORM))
(MAPCAN #'(LAMBDA (ELEMENT)
(LIST | | ELEMENT) )
(CDR LT-FORM) )
(LIST '/) ) ) )
(T (WRITE T ";LT-type " (LT-TYPE LT-FORM)
" not acceptable to DPYLIST-S !" (BREAK DPYLIST-S) )) ) )
(DEFUN TCONC (ADDITEM PTR)
(OR (CONSP PTR) (BREAK "TCONC - PTR not a CONS-cell!"))
(COND ((CDR PTR)
(RPLACD PTR (CDR (RPLACD (CDR PTR) (NCONS ADDITEM)))) )
(T (RPLACD PTR (CAR (RPLACA PTR (NCONS ADDITEM))))) ) )
(DEFUN LCONC (ADDLIST PTR)
(OR (CONSP PTR) (BREAK "LCONC - PTR not a CONS-cell!"))
(COND ((NULL ADDLIST) PTR)
(T (COND ((CDR PTR)
(RPLACD PTR (LAST (RPLACD (CDR PTR)
ADDLIST ))) )
(T (RPLACD PTR
(LAST (CAR (RPLACA PTR
ADDLIST ))) )) )) ) )
(DEFUN TERMSORT (LT-TERM)
(LET ((TERMSORT (CASEQ (LT-TYPE LT-TERM)
(QUANTIFIERFORM (#.(THE-OF:LT-QUANT . QSORT) LT-TERM))
(SIMPLEFORM (GET LT-TERM 'PROPERSORT))
((F-TERM ATOMICPROPO NEGPROPO CONJPROPO DISJPROPO)
(GET (PFC-CONCEPT LT-TERM) 'VALUE-SORT))
(↑-TERM (CONS (↑↓-MARKER LT-TERM)
(TERMSORT (↑↓-MATRIX LT-TERM)) ))
(↓-TERM (TERMSORT (↑↓-MATRIX LT-TERM)))
(λ-PAIR (CDR LT-TERM))
(T (BREAK "TERMSORT - unexpected term-type")) )) )
(OR TERMSORT (WRITE T "; No termsort for " LT-TERM
(BREAK TERMSORT) )) ) )
(DEFUN NORMALIZE-TERMSORTEXPR (TERMSORTEXPR)
(DO ((TS-TAIL TERMSORTEXPR (CDR TS-TAIL))
(TALLY 0 (1+ TALLY)) )
((ATOM TS-TAIL)
(COND ((> TALLY 1)
(RPLACA TERMSORTEXPR (IMPLODE (LIST '↑ (+ 48. TALLY))))
(RPLACD TERMSORTEXPR TS-TAIL) ))
TERMSORTEXPR )
(OR (EQ '↑ (CAR TS-TAIL))
(BREAK "NORMALIZE-TERMSORTEXPR - unexpected CAR") ) ) )
(DEFMACRO PRINCLIST (PRINTLIST)
`(MAPC (FUNCTION PRINC) ,PRINTLIST) )
; CURRENTPOS is a special variable used to keep internal track of where we
; are in the printline; CHARPOS should do this, but doesn't, apparently
; because the ELISP interface does not preserve CHARPOS-type information
; when it handles output from programs. By definition, CURRENTPOS is the
; first unfilled print-position on the current line, or in other words,
; the print-position of the next character to be printed (should there be one)
; on the current line.
(DEFMACRO PRINSOURCECHUNK ()
`(PROGN (SETQ PLINE SOURCELIST
SOURCELIST (CDR TAKEPTR)
SOURCETAIL SOURCELIST
CURRENTPOS (+ CURRENTPOS TCHUNKSIZE)
TCHUNKSIZE 0
PCHUNKSIZE 0 )
(COND (TAKEPTR (RPLACD TAKEPTR NIL))
(T (BREAK "PRINSOURCECHUNK - null TAKEPTR !")) )
(SETQ TAKEPTR NIL)
(PRINCLIST PLINE) ) )
(DEFMACRO GETSBQLINE (SOURCEATOM)
`(DO ((SOURCETAIL (COND ((EQ '/{ (CAR ,SOURCEATOM)) (CDDDR ,SOURCEATOM))
(T ,SOURCEATOM) )
(CDR SOURCETAIL) )
(OUTLINE ,SOURCEATOM) )
((OR (NULL SOURCETAIL) (EQ (CADR SOURCETAIL) '$VAR$))
(SETQ ,SOURCEATOM (CDDR SOURCETAIL))
(COND (SOURCETAIL (RPLACD SOURCETAIL NIL)))
OUTLINE ) ) )
(DEFMACRO NEXTITEMSIZE (LIST)
`(FLATC (CAR ,LIST)) )
(DEFMACRO PRINITEMS (NUMATOM SOURCEATOM)
`(DO ((RPT ,NUMATOM (1- RPT)))
((ZEROP RPT))
(SETQ CURRENTPOS (+ CURRENTPOS (NEXTITEMSIZE ,SOURCEATOM)))
(PRINC (POP ,SOURCEATOM)) ) )
(DEFMACRO PRINSUBQUANT1 (QLINEATOM)
`(LET ((SBQLINE (GETSBQLINE ,QLINEATOM)))
(PRINITEMS 2 SBQLINE) ;; '/{ , <determiner>
(COND ((EQ (CAR SBQLINE) '/ ) (PRINITEMS 1 SBQLINE))) ;; if space, print it
(POP SBQLINE) ;; jettison '$VAR$
(SETQ PERIODCOL (+ CURRENTPOS MAXVARLENGTH))
; (BREAK PSBQ1)
(TAB (- PERIODCOL (NEXTITEMSIZE SBQLINE)))
(PRINITEMS 2 SBQLINE) ;; <variable>, '/.
(STRAIGHTPRIN SBQLINE) ) )
(DEFMACRO PRINSUBQUANT2 (QLINEATOM)
`(LET ((SBQLINE (GETSBQLINE ,QLINEATOM)))
; (BREAK PSBQ2)
(TAB (- PERIODCOL (NEXTITEMSIZE SBQLINE)))
(PRINITEMS 2 SBQLINE) ;; <variable>, '/.
(STRAIGHTPRIN SBQLINE) ) )
(DEFMACRO GETQUANTLINE (SOURCEATOM)
`(DO ((SOURCETAIL ,SOURCEATOM (CDR SOURCETAIL))
(OUTLINE ,SOURCEATOM)
(BRACECOUNT 1) )
((ZEROP BRACECOUNT) (SETQ ,SOURCEATOM (CDR SOURCETAIL))
(RPLACD SOURCETAIL NIL)
OUTLINE )
(CASEQ (CADR SOURCETAIL)
(/{ (SETQ BRACECOUNT (1+ BRACECOUNT)))
(/} (SETQ BRACECOUNT (1- BRACECOUNT))) ) ) )
(DEFMACRO GETλ-LINE (SOURCEATOM)
`(DO ((SOURCETAIL ,SOURCEATOM (CDR SOURCETAIL))
(OUTLINE ,SOURCEATOM) )
((EQ (CAR SOURCETAIL) '|).|) (SETQ ,SOURCEATOM (CDR SOURCETAIL)) ;(
(RPLACD SOURCETAIL NIL)
OUTLINE ) ) )
(DEFMACRO MAXVARIABLENGTH (QLINEATOM)
`(LET ((VARLIST (MAPCON (FUNCTION (LAMBDA (QLTAIL)
(COND ((EQ (CAR QLTAIL) '$VAR$)
(NCONS (CADR QLTAIL)) )) ))
,QLINEATOM )))
(APPLY (FUNCTION MAX) (MAPCAR (FUNCTION (LAMBDA (VAR)
(FLATC VAR) ))
VARLIST )) ) )
;(DEFMACRO TAB (POS &optional FILENAME)
; `(CHARPOS ,FILENAME ,POS) )
; CHARPOS doesn't work as advertised in the Moonual, and won't take
; a second fixnum argument without giving a "non-fixnum-arg" error.
;(PROGN (TERPRI)(TERPRI)(TAB 6)(PRIN1 (CHARPOS T))(PRIN1 'AB)(CHARPOS T))
;(PROGN (TERPRI)(TERPRI)(TAB 6)(TAB 4)(PRIN1 (CHARPOS T))(PRIN1 'AB)(CHARPOS T))
(DEFMACRO SPACELEFT ()
`(- (LINEL NIL) CURRENTPOS) )
(DEFUN STRAIGHTPRIN (SOURCELIST)
(DO ((SOURCETAIL SOURCELIST (CDR SOURCETAIL))
(LAGPTR NIL SOURCETAIL) ;; - points to SOURCETAIL of previous iteration.
(PCHUNKSIZE 0 NEWPCHUNKSIZE) ;; - NEWPCHUNKSIZE less the size of the
;; symbol (CAR SOURCETAIL).
(NEWPCHUNKSIZE 0) ;; - the size of the sourcechunk beginning with
;; (CAR SOURCELIST) and running through (CAR SOURCETAIL).
(TCHUNKSIZE 0) ;; - the size of what PRINSOURCECHUNK would print if called.
(REMNANTSIZE 0) ;; - the size of the chunk between the last breakoint
;; symbol and the beginning of a quantifier or λ-expr.
(PLINE) ;; - PRINSOURCECHUNK's list of symbols to print.
(TAKEPTR) ) ;; - points to a tail of SOURCETAIL whose CAR is the last
;; breakpoint symbol encountered (i.e., the last symbol
;; that PRINCOURCECHUNK would print if called).
((NULL SOURCETAIL) (SETQ CURRENTPOS (+ CURRENTPOS PCHUNKSIZE))
(PRINCLIST SOURCELIST) )
A (COND ((MEMQ (CAR SOURCETAIL) '( /{ |(λ| )) ;)
;; left brace signals the beginning of a quantifier,
;; left-paren-λ signals the beginning of a λ-expr.
(SETQ REMNANTSIZE (- PCHUNKSIZE TCHUNKSIZE))
; (BREAK STP:TEST1)
(COND (TAKEPTR (PRINSOURCECHUNK)))
;; print any characters accumulated before new q- or λ-expr
(COND ((< (- (SPACELEFT) REMNANTSIZE) 25)
(TERPRI)
(SETQ CURRENTPOS 1)
(TAB 2) ))
;; If there is insufficient space left on the current line, go to the next.
;; The test here could be much more sophisticated, depending on the
;; length and structure of the next quantifier or λ-expr.
; (BREAK STP:TEST2)
(COND ((> REMNANTSIZE 0) (SETQ TAKEPTR LAGPTR
TCHUNKSIZE REMNANTSIZE )
(PRINSOURCECHUNK) ))
(SETQ SOURCETAIL (SETQ SOURCELIST
(CASEQ (CAR SOURCETAIL)
(/{ (PRINQUANT SOURCETAIL))
(|(λ| (PRINλ-EXPR SOURCETAIL)) ;)
(T (BREAK "STRAIGHTPRIN:Q∨λBRANCH")))))
(GO A) ))
(SETQ NEWPCHUNKSIZE (+ PCHUNKSIZE (NEXTITEMSIZE SOURCETAIL)))
(COND ((> (+ CURRENTPOS NEWPCHUNKSIZE)
(1+ (LINEL NIL)) )
; (BREAK STPRIN-T)
(PRINSOURCECHUNK)
(TERPRI) ; (TERPRI)
; (BREAK STRAIGHTPRIN)
(SETQ CURRENTPOS 1)
(TAB 2)
(GO A) )
((#.(ISA . BREAK-BEFORE-POINT) (CAR SOURCETAIL))
(SETQ TAKEPTR LAGPTR
TCHUNKSIZE PCHUNKSIZE ) )
((#.(ISA . BREAK-POINT) (CAR SOURCETAIL))
(SETQ TAKEPTR SOURCETAIL
TCHUNKSIZE NEWPCHUNKSIZE ) ) ) ) )
(DEFUN PRINQUANT (SOURCELIST &aux (QLINE (GETQUANTLINE SOURCELIST))
(MAXVARLENGTH (MAXVARIABLENGTH QLINE))
PERIODCOL )
(PRINSUBQUANT1 QLINE)
(COND (QLINE (DO () ((NULL QLINE)) (PRINSUBQUANT2 QLINE))))
SOURCELIST )
(DEFUN PRINλ-EXPR (SOURCELIST &aux (λ-LINE (GETλ-LINE SOURCELIST)))
(PRINITEMS (LENGTH λ-LINE) λ-LINE)
SOURCELIST )
(DEFUN TAB (POS)
(COND ((ZEROP POS) (TERPRI) (PRINC ";TAB to 0 ??!") (BREAK TAB))
((< POS CURRENTPOS) (TERPRI) (SETQ CURRENTPOS 1)) )
(DO ()
((= POS CURRENTPOS))
(SETQ CURRENTPOS (1+ CURRENTPOS))
(PRINC '/ ) ) )
(DEFUN CURRENTPOS (&optional (FILENAME T))
(CHARPOS FILENAME) )
(SETQ YHπ-FLAG NIL)
(SETQ *CONCEPTS* '(*TOP*))
(SETQ ALPHABET '(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z)
REVERSE-ALPHABET (REVERSE ALPHABET) )
(SETQ ALPHA-NCONSES (MAPCAR #'NCONS ALPHABET))
(SETQ *-ASCII 42.)
(DEFSTRUCT (LINK-NODE (TYPE TREE) (CONC-NAME LINK-))
KEY A-LIST )
(DEFSTRUCT (LEAF-NODE (TYPE TREE) (CONC-NAME LEAF-))
KEY PLIST )
(DEFSTRUCT (LTCC-PLIST (TYPE TREE) (CONC-NAME LTCC-))
(PLIST-IDENT '*CC-PLIST*) PROPLIST )
; This function presupposes that LINFORMULA is non-atomic. Provided that
; the global variable YHπ-FLAG is non-null, this fn will return the name of
; a YH-UNIT having the internal translation of LINFORMULA as value of the
; property LT-FORMULA, and an appropriate atom as value of the property LT-TYPE.
(DEFUN NRML-ANL-YZE-LINFORMULA (LINFORMULA &optional YH-UNIT)
(LET ((LT-FORM (ENCODE-LINFORMULA LINFORMULA)))
(NORMALIZE-CMPD-CONCEPT
LT-FORM (ANALYZE-CMPD-CONCEPT LT-FORM) NIL YH-UNIT ) ) )
(DEFMACRO NRML-FORMULA (LT-FORM)
`(ATC-GET (NRML-ANL-YZE ,LT-FORM) 'LT-FORMULA) )
(DEFMACRO NRML-ANL-YZE (LT-FORM . AL-VARS-TAIL)
`(LET ((LT-FORM ,LT-FORM))
(COND ((ATOM LT-FORM) LT-FORM)
(T (LET ((AL-VARS ,(CAR AL-VARS-TAIL)))
(NORMALIZE-CMPD-CONCEPT
LT-FORM
(ANALYZE-CMPD-CONCEPT LT-FORM AL-VARS)
AL-VARS ) )) ) ) )
(DEFMACRO LT-CONCEPT-TYPE (LT-FORM)
`(LET ((LT-TYPE (LT-TYPE ,LT-FORM)))
(CASEQ LT-TYPE
(λ-EXPR (LT-TYPE (LT-λ-SCOPE ,LT-FORM)))
(T LT-TYPE) ) ) )
(DEFMACRO ADD-NEWLINK (NEWKEY LINK)
`(CAR (SETF* (LINK-A-LIST ,LINK) (CONS (MAKE-LINK-NODE KEY ,NEWKEY
A-LIST NIL )
-*- ))) )
(DEFMACRO LEAF-UNIT (LEAF-NODE)
`(LEAF-PLIST ,LEAF-NODE) )
(DEFUN NORMALIZE-CMPD-CONCEPT (LT-FORM CC-INDEX-KEYS
&optional ANALYSIS-LIST-VARS YH-UNIT )
(CASEQ (LT-CONCEPT-TYPE LT-FORM)
(SIMPLEFORM LT-FORM)
;; is more code needed here - to make LT-FORM
;; an atomic concept if it isn't one already?
(T (DO ((INDEX-KEYS CC-INDEX-KEYS (CDR INDEX-KEYS))
(NC-CURRENTNODE *CONCEPTS*) ;; the NC- prefix connotes "normalize concept".
(CURRENTKEY) )
((NULL INDEX-KEYS)
; (BREAK INDX-CPT:TEST)
(PROG1 (COND ((LEAF-PLIST NC-CURRENTNODE))
(T (INITIALIZE-CMPD-CONCEPT
NC-CURRENTNODE LT-FORM YH-UNIT ) ) )
(COND (ANALYSIS-LIST-VARS
(MAPC #'(LAMBDA (ANALYSIS-LIST-VAR)
(SET ANALYSIS-LIST-VAR
(CONS (CONS (LEAF-PLIST NC-CURRENTNODE)
CC-INDEX-KEYS )
(SYMEVAL ANALYSIS-LIST-VAR) ) ) )
ANALYSIS-LIST-VARS ) )) ) )
(SETQ CURRENTKEY (CAR INDEX-KEYS)
NC-CURRENTNODE
(COND ((ASSQ CURRENTKEY (LINK-A-LIST NC-CURRENTNODE)))
(T (ADD-NEWLINK CURRENTKEY NC-CURRENTNODE)) ))))))
(DEFUN INITIALIZE-CMPD-CONCEPT (LEAF-NODE LT-FORMULA YH-UNIT)
(COND ((#.(ISA-OF:LT . λ-EXPR) LT-FORMULA)
(SETQ LT-FORMULA (λ-UNSUBST LT-FORMULA)) ))
(COND (YHπ-FLAG (OR YH-UNIT (SETQ YH-UNIT (π-MAKE-UNIT NIL)))
(π-PUTPROP YH-UNIT LT-FORMULA 'LT-FORMULA)
(π-PUTPROP YH-UNIT (LT-TYPE LT-FORMULA) 'LT-TYPE)
(SETF (LEAF-PLIST LEAF-NODE) YH-UNIT) )
(T (LET ((CC-PROPLIST (MAKE-LTCC-PLIST)))
(PUTPROP CC-PROPLIST LT-FORMULA 'LT-FORMULA)
(PUTPROP CC-PROPLIST (LT-TYPE LT-FORMULA) 'LT-TYPE)
(SETF (LEAF-PLIST LEAF-NODE) CC-PROPLIST) )) ) )
(DEFMACRO CONCEPT-BODY (LT-FORM)
`(COND ((#.(ISA-OF:LT . λ-EXPR) ,LT-FORM) (LT-λ-SCOPE ,LT-FORM))
(T ,LT-FORM) ) )
(DEFMACRO 1ST-PROCESS-↑-MATRIX (↑-MATRIX-EXPR λ-EXPR-FLAG)
`(LET ((↑-MATRIX-ANALYSIS-LIST))
(NRML-ANL-YZE ,↑-MATRIX-EXPR (NCONS '↑-MATRIX-ANALYSIS-LIST))
(FIX-AL ↑-MATRIX-ANALYSIS-LIST)
;; ↑-MATRIX-ANALYSIS-LIST :
;; ((<normalized-concept-expr> <cc-op> <component-concept-expr> ... ) ... )
(COND (,λ-EXPR-FLAG
(NORMRAISE-CC (CDAR ↑-MATRIX-ANALYSIS-LIST)
(LT-λ-PREFIX ,↑-MATRIX-EXPR) ) )
(T (NORMRAISE-CC (CDAR ↑-MATRIX-ANALYSIS-LIST))) ) ) )
(DEFMACRO PROCESS-↑-MATRIX (↑-MATRIX-EXPR λ-EXPR-FLAG)
`(PROGN (NRML-ANL-YZE ,↑-MATRIX-EXPR AL-VARS)
(FIX-AL ↑-MATRIX-ANALYSIS-LIST)
(COND (,λ-EXPR-FLAG
(NORMRAISE-CC (CDAR ↑-MATRIX-ANALYSIS-LIST)
(LT-λ-PREFIX ,↑-MATRIX-EXPR) ) )
(T (NORMRAISE-CC (CDAR ↑-MATRIX-ANALYSIS-LIST))) ) ) )
(DEFMACRO COLLECT-IMAGES (MATCH-PKLS LT-FORM)
`(COND ((#.(ISA-OF:LT . λ-EXPR) ,LT-FORM)
(DO ((MATCH-PKL-TAIL ,MATCH-PKLS (CDR MATCH-PKL-TAIL))
(PKL-POOL (LT-PATHKEYLISTS ,LT-FORM))
(IMAGES-PTR (NCONS NIL))
(REFLECTION) )
((NULL MATCH-PKL-TAIL) (CAR IMAGES-PTR))
(SETQ REFLECTION
(CAR (SOME PKL-POOL
#'(LAMBDA (PKL)
(EQUAL (PATHKEYS PKL)
(PATHKEYS (CAR MATCH-PKL-TAIL)) ) ) )) )
(COND (REFLECTION
(SETF (λ-TERMSORT (CAR MATCH-PKL-TAIL))
(COPYALLCONS (λ-TERMSORT REFLECTION)) )
(TCONC (CAR MATCH-PKL-TAIL) IMAGES-PTR) )) ) )) )
; A "pathkey" is a string of one or more letters representing the decomposition
; path through an lt-expression to a single rolelink occurring within that
; expression. A "pathkey digit" is one of the component letters of a pathkey.
; An "xpathkey" is an exploded (or more often, an unimploded) pathkey.
; A "pathkeylist" is a list with CAR a termsort, and CDR a list of pathkeys,
; corresponding to a set of rolelinks that share the same argument. Thus, a
; pathkeylist plays a role similar to that of a variable in the external
; logical notation. A LISP variable whose name contains the plural
; "pathkeylists" is used to store a list of pathkeylists.
(DEFMACRO MERGED-PKLS (PATHKEYLISTS)
;; rolemerged criterion: the presence in a multi-pathkey pathkeylist
;; of pathkeys having different first digits.
`(MAPCAN #'(LAMBDA (PKEYLIST)
(COND ((AND (CDR (PATHKEYS PKEYLIST))
(DO ((1STDIGIT (GETCHAR (CAR (PATHKEYS PKEYLIST)) 1))
(PKLTAIL (CDR (PATHKEYS PKEYLIST)) (CDR PKLTAIL)) )
((NULL PKLTAIL) NIL)
(OR (EQ (GETCHAR (CAR PKLTAIL) 1) 1STDIGIT)
(RETURN T) ) ) )
(NCONS PKEYLIST) )) )
,PATHKEYLISTS ) )
(DEFMACRO SETUP-λ-EXPR (NEWPKEYLIST OLDPKEYLISTS KEYDIGIT λ-SCOPE)
`(LET* ((λ-SCOPE ,λ-SCOPE)
(PATHKEYLISTS
(ORDER-PATHKEYLISTS
(CONS ,NEWPKEYLIST
(COND (,OLDPKEYLISTS
(SELECT&SHORTEN ,KEYDIGIT
,OLDPKEYLISTS
λ-SCOPE ) )) ) ) ) )
(COND ((AND (EQ 'ATOMICPROPO (LT-TYPE λ-SCOPE))
(ATOM-CONVERTIBLE PATHKEYLISTS λ-SCOPE) )
(PFC-CONCEPT λ-SCOPE) )
((MAKE-LT-λ-EXPR
λ-PREFIX (MAKE-LT-λ-PREFIX PATHKEYLISTS PATHKEYLISTS)
λ-SCOPE λ-SCOPE ) ) ) ) )
(DEFMACRO PREVIOUS-LETTER (LETTER)
`(OR (CADR (MEMQ ,LETTER REVERSE-ALPHABET))
(BREAK "PREVIOUS-LETTER - off the beginning") ) )
(DEFMACRO ANALYZE-ADVERBIALIZATION (LT-PF-FORM)
`(LET* ((PF-ATOM (PFC-CONCEPT (CONCEPT-BODY ,LT-PF-FORM)))
(ROLEXICON (GET PF-ATOM 'ROLEXICON)) )
(OR ROLEXICON (WRITE T "; no rolexicon for " PF-ATOM
(BREAK "ANALYZE-ADVERBIALIZATION") ))
(LET* ((ADV-COMPONENTS
(MAPCAR #'(LAMBDA (ROLINK)
(CDR (ASSQ (ROLEMARK ROLINK) ROLEXICON)) )
(NTHCDR (LENGTH (GET PF-ATOM 'COREROLES))
(ROLELINKS (CONCEPT-BODY ,LT-PF-FORM)) ) ) )
(CC-OP (IMPLODE (APPEND '(A D V B *)
(NCONS (NTH (1- (LENGTH ADV-COMPONENTS))
ALPHABET )) ))) )
(LIST* CC-OP PF-ATOM ADV-COMPONENTS) ) ) )
(DEFMACRO INST-KEYS (LT-FORM)
;; instantiation criterion: the absence of a pathkeylist of the
;; form (<1-digit-pathkey>) for each rolelink.
`(DO ((ROLINKTAIL (ROLELINKS (CONCEPT-BODY ,LT-FORM)) (CDR ROLINKTAIL))
(TESTPKLTAIL ALPHA-NCONSES (CDR TESTPKLTAIL))
(PKEYLISTS (COND ((#.(ISA-OF:LT . λ-EXPR) ,LT-FORM)
(LT-PATHKEYLISTS ,LT-FORM) )))
(INST-KEYS) )
((NULL ROLINKTAIL) (GOOD-NREVERSE INST-KEYS))
(COND ((NOT (SOME PKEYLISTS #'(LAMBDA (PKL)
(EQUAL (CAR TESTPKLTAIL)
(PATHKEYS PKL) ) )))
(PUSH (CAAR TESTPKLTAIL) INST-KEYS) )) ) )
(DEFUN ORDER-JUNCTS (NORML-JUNCT-LIST JUNCT-ANALYSIS-LIST)
;; NORML-JUNCT-LIST : (<normalized component-junct-cc-plist> ... )
;; JUNCT-ANALYSIS-LIST :
;; ((<normalized-concept-expr> <cc-op> <component-concept-expr> ... ) ... )
(SORT NORML-JUNCT-LIST
#'(LAMBDA (JUNCT1 JUNCT2)
(COND ((ATOM JUNCT1)
(COND ((ATOM JUNCT2) (ALPHALESSP JUNCT1 JUNCT2))
(T T) ) )
(T (COND ((ATOM JUNCT2) NIL)
(T ;;(the following DO loop is too big to indent properly)
(DO ((KEYLIST1 (CDR (ASSQ (GET JUNCT1 'LT-FORMULA)
JUNCT-ANALYSIS-LIST )))
(KEYLIST2 (CDR (ASSQ (GET JUNCT2 'LT-FORMULA)
JUNCT-ANALYSIS-LIST )))
(COMPOUNDKEY-PAIRS) (KL1-LENGTH) (KL2-LENGTH) )
()
A (SETQ KL1-LENGTH (LENGTH KEYLIST1)
KL2-LENGTH (LENGTH KEYLIST2) )
(COND ((< KL1-LENGTH KL2-LENGTH) (RETURN T))
((< KL2-LENGTH KL1-LENGTH) (RETURN NIL)) )
(MAPC #'(LAMBDA (KEY1 KEY2)
(COND ((ATOM KEY1)
(COND ((ATOM KEY2)
(COND ((EQ KEY1 KEY2) NIL)
((ALPHALESSP KEY1 KEY2)
(RETURN T) )
(T (RETURN NIL)) ) )
(T (RETURN T)) ) )
(T (COND ((ATOM KEY2) (RETURN NIL))
(T (ENDADD (CONS (GET KEY1 'LT-FORMULA)
(GET KEY2 'LT-FORMULA) )
COMPOUNDKEY-PAIRS )) )) ) )
KEYLIST1 KEYLIST2 )
(COND (COMPOUNDKEY-PAIRS
(SETQ KEYLIST1 (CDR (ASSQ (CAAR COMPOUNDKEY-PAIRS)
JUNCT-ANALYSIS-LIST ))
KEYLIST2 (CDR (ASSQ (CDR (POP COMPOUNDKEY-PAIRS))
JUNCT-ANALYSIS-LIST )) )
(GO A) )
(T (BREAK "ORDER-JUNCTS - error: can't order juncts!")) )
) ) )) ) ) ) )
; this fn gets the position of PKLIST among the pathkeylists of λ-EXPR;
; if λ-EXPR has been converted to an atom, then PKLIST will have just one
; member, consisting of a single pathkey digit representing the right
; corerole position.
(DEFMACRO GET-PKL-POSITION (PKLIST λ-EXPR)
`(COND ((ATOM ,λ-EXPR) (CAR (PATHKEYS ,PKLIST)))
(T (DO ((PKLISTAIL (LT-PATHKEYLISTS ,λ-EXPR) (CDR PKLISTAIL))
(TALLYTAIL ALPHABET (CDR TALLYTAIL)) (PKLIST ,PKLIST) )
((EQUAL PKLIST (CAR PKLISTAIL)) (CAR TALLYTAIL))
(OR PKLISTAIL (BREAK "GET-PKL-POSITION - error")) )) ) )
(DEFMACRO GET-Q-OP (PKLIST1 λ-EXPR1 PKLIST2 λ-EXPR2)
`(LET ((QUANTKEY1 (GET-PKL-POSITION ,PKLIST1 ,λ-EXPR1))
(QUANTKEY2 (GET-PKL-POSITION ,PKLIST2 ,λ-EXPR2)) )
(IMPLODE (NCONC (EXPLODE 'QUANT) (LIST '* QUANTKEY1 QUANTKEY2))) ) )
(DEFMACRO ↑-ASCII (DECNUMBER)
`(= 94. ,DECNUMBER) )
(DEFMACRO λ-ASCII (DECNUMBER)
`(= 8. ,DECNUMBER) )
(DEFMACRO *-OR-↑-ASCII (DECNUMBER)
`(MEMBER ,DECNUMBER '(42. 94.)) )
(DEFMACRO *-OR-C-ASCII (DECNUMBER)
`(MEMBER ,DECNUMBER '(42. 67.)) )
(DEFMACRO C-ASCII (DECNUMBER)
`(= 67. ,DECNUMBER) )
(DEFMACRO 2:9-ASCII (DECNUMBER)
`(AND (> ,DECNUMBER 49.) (< ,DECNUMBER 58.)) )
(DEFMACRO NUMERAL-ASCII (DECNUMBER)
`(AND (> ,DECNUMBER 47.) (< ,DECNUMBER 58.)) )
(DEFMACRO λ↑-RAISE-CC-OP (CC-OP)
`(LET ((XPL-OP (EXPLODEN ,CC-OP)))
(COND ((↑-ASCII (CAR XPL-OP)) (IMPLODE (APPEND '(λ ↑) XPL-OP)))
((AND (λ-ASCII (CAR XPL-OP))
(↑-ASCII (CADR XPL-OP)) )
(COND ((*-OR-↑-ASCII (CADDR XPL-OP))
(SETF* (CDDR XPL-OP) (CONS 50. -*-))
(IMPLODE XPL-OP) )
((2:9-ASCII (CADDR XPL-OP))
(SETF* (CADDR XPL-OP) (1+ -*-))
(OR (2:9-ASCII (CADDR XPL-OP))
(BREAK "λ↑-RAISE-CC-OP - not enough numerals.") )
(IMPLODE XPL-OP) )
(T (IMPLODE (APPEND '(λ ↑ *) XPL-OP))) ) )
(T (IMPLODE (APPEND '(λ ↑ *) XPL-OP))) ) ) )
(DEFMACRO RAISE-CC (LT-FORM)
`(COND ((EQ (LT-TYPE ,LT-FORM) '↑-TERM) (RAISE↑-TERM ,LT-FORM))
(T (MAKE-↑↓-TERM ↑↓-MARKER '↑
↑↓-MATRIX ,LT-FORM )) ) )
(DEFMACRO RAISE-CC-OP (CC-OP)
`(LET ((XPL-OP (EXPLODEN ,CC-OP)))
(COND ((↑-ASCII (CAR XPL-OP))
(COND ((*-OR-C-ASCII (CADR XPL-OP))
(SETF* (CDR XPL-OP) (CONS 50. -*-))
(IMPLODE XPL-OP) )
((2:9-ASCII (CADR XPL-OP))
(SETF* (CADR XPL-OP) (1+ -*-))
(OR (2:9-ASCII (CADR XPL-OP))
(BREAK "RAISE-CC-OP - not enough numerals.") )
(IMPLODE XPL-OP) )
(T (BREAK "RAISE-CC-OP - improper cc-op.")) ) )
((AND (λ-ASCII (CAR XPL-OP))
(↑-ASCII (CADR XPL-OP)) )
(COND ((OR (*-OR-↑-ASCII (CADDR XPL-OP))
(2:9-ASCII (CADDR XPL-OP)) )
(IMPLODE (CONS '↑ XPL-OP)) )
(T (IMPLODE (APPEND '(↑ *) XPL-OP))) ) )
(T (IMPLODE (APPEND '(↑ *) XPL-OP))) ) ) )
(DEFMACRO GET-BASE-OP (CC-OP)
`(LET* ((XPL-OP (NREVERSE (CDR (MEMQ *-ASCII (NREVERSE (EXPLODEN ,CC-OP))))))
(SHORT-XPL-OP (CDR (MEMQ *-ASCII XPL-OP))) )
(IMPLODE (COND (SHORT-XPL-OP) (T XPL-OP))) ) )
(DEFMACRO GET-S&S-KEY (CC-OP CC-KEYNUM)
`(LET ((BASE-OP (GET-BASE-OP ,CC-OP)))
(CASEQ BASE-OP
((INST QUANT CNCT) (NTH (- ,CC-KEYNUM 2) ALPHABET))
(T (BREAK "GET-S&S-KEY - unrecognized base-cc-op.")) ) ) )
(DEFUN NORMRAISE-CC (CC-KEYS &optional λ-PREFIX)
;; CC-KEYS: (<cc-op> <component-concept-expr> ... )
(DO ((CC-KEYTAIL CC-KEYS (CDR CC-KEYTAIL))
(KEYNUM 0 (1+ KEYNUM))
(NORMRAISEDKEYS) )
((NULL CC-KEYTAIL) (NREVERSE NORMRAISEDKEYS))
(PUSH
(COND
((ATOM (CAR CC-KEYTAIL))
(COND ((= KEYNUM 0)
(COND (λ-PREFIX (λ↑-RAISE-CC-OP (CAR CC-KEYTAIL)))
(T (RAISE-CC-OP (CAR CC-KEYTAIL))) ) )
(T (RAISEATOM (CAR CC-KEYTAIL))) ))
(T (LET* ((MATCH-PKLS
(COND (λ-PREFIX (COND ((= 1 KEYNUM)
(COPYALLCONS (CDR λ-PREFIX)) )
(T (SELECT&SHORTEN
(GET-S&S-KEY (CAR CC-KEYS)
KEYNUM )
(CDR λ-PREFIX)
(LT-λ-SCOPE (CAR CC-KEYTAIL)) )) ))) )
(ORIG-λPKL-IMAGES
(COND (MATCH-PKLS
(COLLECT-IMAGES MATCH-PKLS (CAR CC-KEYTAIL)) )) )
(NON-IMAGE-λPKLS
(COND ((#.(ISA-OF:LT . λ-EXPR) (CAR CC-KEYTAIL))
(SUBSET #'(LAMBDA (PKEYLIST)
(NOT (MEMBER PKEYLIST
ORIG-λPKL-IMAGES)))
(LT-PATHKEYLISTS (CAR CC-KEYTAIL)) ) )) )
(NEW-CC-EXPR
(COND (ORIG-λPKL-IMAGES
(MAKE-LT-λ-EXPR
λ-PREFIX (MAKE-LT-λ-PREFIX
PATHKEYLISTS
(ORDER-PATHKEYLISTS
(RAISE-λ-TERMSORTS
ORIG-λPKL-IMAGES ) ) )
λ-SCOPE
(RAISE-CC
(COND (NON-IMAGE-λPKLS
(MAKE-LT-λ-EXPR
λ-PREFIX
(MAKE-LT-λ-PREFIX
PATHKEYLISTS
(ORDER-PATHKEYLISTS
NON-IMAGE-λPKLS ) )
λ-SCOPE
(LT-λ-SCOPE (CAR CC-KEYTAIL)) ) )
(T (LT-λ-SCOPE (CAR CC-KEYTAIL))) ))))
(T (RAISE-CC (CAR CC-KEYTAIL))) ) )
(NEW-λ-PREFIX
(COND ((#.(ISA-OF:LT . λ-EXPR) NEW-CC-EXPR)
(LT-λ-PREFIX NEW-CC-EXPR) )) )
(NEW-CC-KEYS (CDR (ASSQ (CAR CC-KEYTAIL)
↑-MATRIX-ANALYSIS-LIST ))) )
(COND (NEW-λ-PREFIX
(NORMALIZE-CMPD-CONCEPT
NEW-CC-EXPR
(NORMRAISE-CC NEW-CC-KEYS NEW-λ-PREFIX)
AL-VARS ) )
(T (NORMALIZE-CMPD-CONCEPT
NEW-CC-EXPR
(NORMRAISE-CC NEW-CC-KEYS)
AL-VARS )) ) )) )
NORMRAISEDKEYS ) ) )
; QV-QUASI-UNSUBST searches out each occurrence of the quantifier or variable
; UNSUBSTERM in LT-FORM, [a previous version removed UNSUBSTERM from the
; dependency lists of any quantifiers occurring within LT-FORM,] and returns a
; list of xpathkeys (i.e., unimploded pathkeys), one for each place in LT-FORM
; in which UNSUBSTERM occurs. QV-QUASI-UNSUBST is called with 2 arguments by
; ANALYZE-CMPD-CONCEPT and ENCODE-LINFORMULA-S, and in turn calls itself with
; 3 arguments, the third argument, KEYDIGIT, being consed onto the xpathkeys
; returned by recursive calls to QV-QUASI-UNSUBST.
(DEFUN QV-QUASI-UNSUBST (UNSUBSTERM LT-FORM &optional KEYDIGIT)
(CASEQ (LT-TYPE LT-FORM)
((ATOMICPROPO F-TERM)
(DO ((RL-TAIL (ROLELINKS LT-FORM) (CDR RL-TAIL))
(NEWKEYDIGITAIL ALPHABET (CDR NEWKEYDIGITAIL))
(OUTXPKLIST) (NEWFORM) (XPATHKEYLIST) )
((NULL RL-TAIL) OUTXPKLIST)
(SETQ NEWFORM (ARGUMENT (CAR RL-TAIL)))
(COND ((SETQ XPATHKEYLIST
(CASEQ (LT-TYPE NEWFORM)
(λ-PAIR NIL)
((QUANTIFIERFORM SIMPLEFORM)
(COND ((EQ NEWFORM UNSUBSTERM)
(NCONS (NCONS (CAR NEWKEYDIGITAIL))) )) )
(↓-TERM
(COND ((EQ (↑↓-MATRIX NEWFORM) UNSUBSTERM)
(NCONS (NCONS (CAR NEWKEYDIGITAIL))) )) )
(T (QV-QUASI-UNSUBST UNSUBSTERM
(ARGUMENT (CAR RL-TAIL))
(CAR NEWKEYDIGITAIL) )) ) )
(ADDCONC (COND (KEYDIGIT
(MAP #'(LAMBDA (XPATHKEYTAIL)
(SETF* (CAR XPATHKEYTAIL)
(CONS KEYDIGIT -*-) ) )
XPATHKEYLIST ) )
(T XPATHKEYLIST) )
OUTXPKLIST ) )) ) )
(SIMPLEFORM (NCONS (NCONS KEYDIGIT)))
((CONJ-PROPO DISJ-PROPO NEGPROPO ⊃-PROPO)
(DO ((RL-TAIL (ROLELINKS LT-FORM) (CDR RL-TAIL))
(NEWKEYDIGITAIL ALPHABET (CDR NEWKEYDIGITAIL))
(OUTXPKLIST) (XPATHKEYLIST) )
((NULL RL-TAIL) OUTXPKLIST)
(COND ((SETQ XPATHKEYLIST
(QV-QUASI-UNSUBST UNSUBSTERM
(ARGUMENT (CAR RL-TAIL))
(CAR NEWKEYDIGITAIL) ) )
(ADDCONC (COND (KEYDIGIT
(MAP #'(LAMBDA (XPATHKEYTAIL)
(SETF* (CAR XPATHKEYTAIL)
(CONS KEYDIGIT -*-) ) )
XPATHKEYLIST ) )
(T XPATHKEYLIST) )
OUTXPKLIST ) )) ) )
(↑-TERM
(QV-QUASI-UNSUBST UNSUBSTERM (↑↓-MATRIX LT-FORM) KEYDIGIT) )
(λ-EXPR
(QV-QUASI-UNSUBST UNSUBSTERM (LT-λ-SCOPE LT-FORM) KEYDIGIT) )
(QUANTIFIERFORM
(LET ((XPATHKEYLIST
(NCONC (QV-QUASI-UNSUBST UNSUBSTERM
(#.(THE-OF:LT-QUANT . QSORTEXPR) LT-FORM)
'A )
(QV-QUASI-UNSUBST UNSUBSTERM
(#.(THE-OF:LT-QUANT . SCOPE) LT-FORM)
'B ) ) ))
; (COND ((LT-DEPENDENCIES LT-FORM)
; (SETF* (LT-DEPENDENCIES LT-FORM)
; (DELQ UNSUBSTERM -*-) ) ) )
(COND (XPATHKEYLIST
(COND (KEYDIGIT
(MAP #'(LAMBDA (XPATHKEYTAIL)
(SETF* (CAR XPATHKEYTAIL)
(CONS KEYDIGIT -*-) ) )
XPATHKEYLIST ) )
(T XPATHKEYLIST) ) )) ))
(FIXNUM-VECTOR
(DO ((VECTAIL LT-FORM (CDR VECTAIL))
(NEWKEYDIGITAIL ALPHABET (CDR NEWKEYDIGITAIL))
(OUTXPKLIST) )
((NULL VECTAIL) OUTXPKLIST)
(COND ((EQ UNSUBSTERM (CAR VECTAIL))
(ENDADD (COND (KEYDIGIT
(LIST KEYDIGIT (CAR NEWKEYDIGITAIL)) )
(T (NCONS (CAR NEWKEYDIGITAIL))) )
OUTXPKLIST ) )) ) )
(T (BREAK "QV-QUASI-UNSUBST - unrecognized LT-FORM type.")) ) )
(DEFUN ANALYZE-CMPD-CONCEPT (LT-FORM &optional AL-VARS)
(CASEQ (LT-CONCEPT-TYPE LT-FORM)
((ATOMICPROPO F-TERM)
; (SETF (ROLELINKS (CONCEPT-BODY LT-FORM)) ;; move this to construction points.
; (ORDER-ROLELINKS (CONCEPT-BODY LT-FORM)) )
(COND ((#.(ISA-OF:LT . λ-EXPR) LT-FORM)
(LET ((DO-LIST))
(COND ((SETQ DO-LIST (MERGED-PKLS (LT-PATHKEYLISTS LT-FORM)))
(ANALYZE-ROLEMERGE DO-LIST LT-FORM) )
((SETQ DO-LIST (INST-KEYS LT-FORM))
(ANALYZE-INSTANTIATION DO-LIST LT-FORM) )
(T (ANALYZE-ADVERBIALIZATION LT-FORM)) ) ) )
(T (ANALYZE-INSTANTIATION (INST-KEYS LT-FORM) LT-FORM)) ) )
(QUANTIFIERFORM
(*CATCH 'Q-F
(COND ((#.(ISA-OF:LT . λ-EXPR) LT-FORM)
(LET ((DO-LIST (MERGED-PKLS (LT-PATHKEYLISTS LT-FORM))))
(COND (DO-LIST
(*THROW 'Q-F (ANALYZE-ROLEMERGE DO-LIST LT-FORM)) )) ) ))
(LET* ((QUANTBODY (CONCEPT-BODY LT-FORM))
(OLDPATHKEYLISTS (COND ((#.(ISA-OF:LT . λ-EXPR) LT-FORM)
(LT-PATHKEYLISTS LT-FORM))) )
(QSORT-NEWPATHKEYLIST
(ADJUST-λ-TERMSORT
(CONS NIL
(ORDER-PATHKEYS
(MAPCAR #'IMPLODE
(QV-QUASI-UNSUBST
QUANTBODY
(#.(THE-OF:LT-QUANT . QSORTEXPR) QUANTBODY) ) ) ) )
(#.(THE-OF:LT-QUANT . QSORTEXPR) QUANTBODY) ) )
(SCOPE-NEWPATHKEYLIST
(ADJUST-λ-TERMSORT
(CONS NIL
(ORDER-PATHKEYS
(MAPCAR #'IMPLODE
(QV-QUASI-UNSUBST
QUANTBODY
(#.(THE-OF:LT-QUANT . SCOPE) QUANTBODY) ) ) ) )
(#.(THE-OF:LT-QUANT . SCOPE) QUANTBODY) ) )
(QSORTλ-EXPR (SETUP-λ-EXPR QSORT-NEWPATHKEYLIST
OLDPATHKEYLISTS 'A
(#.(THE-OF:LT-QUANT . QSORTEXPR) QUANTBODY) ))
(SCOPEλ-EXPR (SETUP-λ-EXPR SCOPE-NEWPATHKEYLIST
OLDPATHKEYLISTS 'B
(#.(THE-OF:LT-QUANT . SCOPE) QUANTBODY) ))
(Q-OPERATOR (GET-Q-OP QSORT-NEWPATHKEYLIST QSORTλ-EXPR
SCOPE-NEWPATHKEYLIST SCOPEλ-EXPR )) )
(LIST Q-OPERATOR
(#.(THE-OF:LT-QUANT . DETERMINER) QUANTBODY)
(NRML-ANL-YZE QSORTλ-EXPR AL-VARS)
(NRML-ANL-YZE SCOPEλ-EXPR AL-VARS) ) ) ) )
(↑-TERM
(LET* ((λ-EXPR-FLAG (#.(ISA-OF:LT . λ-EXPR) LT-FORM))
(↑-MATRIX-EXPR
(COND
(λ-EXPR-FLAG
(LET ((λ-SCOPE (↑↓-MATRIX (LT-λ-SCOPE LT-FORM))))
(COND ((AND (EQ 'ATOMICPROPO (LT-TYPE λ-SCOPE))
(ATOM-CONVERTIBLE (LT-PATHKEYLISTS LT-FORM)
λ-SCOPE ) )
(PFC-CONCEPT λ-SCOPE) )
(T (SETQ λ-EXPR-FLAG 'UNCONVERTED)
(MAKE-LT-λ-EXPR
λ-PREFIX (MAKE-LT-λ-PREFIX
PATHKEYLISTS
(COPYALLCONS
(LT-PATHKEYLISTS LT-FORM) ) )
λ-SCOPE λ-SCOPE )) ) ) )
(T (↑↓-MATRIX LT-FORM)) ) ) )
(COND ((EQ λ-EXPR-FLAG 'UNCONVERTED)
(LOWER-λ-TERMSORTS (LT-PATHKEYLISTS ↑-MATRIX-EXPR)) ))
(COND ((AND (EQ λ-EXPR-FLAG 'UNCONVERTED)
(EQ 'λ-EXPR (LT-TYPE (LT-λ-SCOPE ↑-MATRIX-EXPR))) )
(SETF* (LT-PATHKEYLISTS ↑-MATRIX-EXPR)
(ORDER-PATHKEYLISTS
(NCONC -*- (COPYALLCONS
(LT-PATHKEYLISTS
(LT-λ-SCOPE ↑-MATRIX-EXPR) ) )) ) )
(SETF* (LT-λ-SCOPE ↑-MATRIX-EXPR) (LT-λ-SCOPE -*-)) ))
(COND ((MEMQ '↑-MATRIX-ANALYSIS-LIST AL-VARS)
(PROCESS-↑-MATRIX ↑-MATRIX-EXPR λ-EXPR-FLAG) )
(T (1ST-PROCESS-↑-MATRIX ↑-MATRIX-EXPR λ-EXPR-FLAG)) ) ) )
(NEGPROPO
(LET* ((JUNCT-MATRIX (ARGUMENT (CAR (ROLELINKS (CONCEPT-BODY LT-FORM)))))
(JUNCT-EXPR
(COND ((#.(ISA-OF:LT . λ-EXPR) LT-FORM)
(LET ((NEWPATHKEYLISTS
(ORDER-PATHKEYLISTS
(SELECT&SHORTEN 'A (LT-PATHKEYLISTS LT-FORM)
JUNCT-MATRIX ) ) ))
(COND ((AND (EQ 'ATOMICPROPO (LT-TYPE JUNCT-MATRIX))
(ATOM-CONVERTIBLE NEWPATHKEYLISTS
JUNCT-MATRIX ) )
(PFC-CONCEPT JUNCT-MATRIX) )
(T (MAKE-LT-λ-EXPR
λ-PREFIX (MAKE-LT-λ-PREFIX
PATHKEYLISTS NEWPATHKEYLISTS )
λ-SCOPE JUNCT-MATRIX )) ) ) )
(T JUNCT-MATRIX) ) ) )
(LIST 'CNCT*A '¬ (NRML-ANL-YZE JUNCT-EXPR AL-VARS)) ) )
((CONJ-PROPO DISJ-PROPO)
(*CATCH 'CD-P
(COND ((#.(ISA-OF:LT . λ-EXPR) LT-FORM)
(LET ((DO-LIST (MERGED-PKLS (LT-PATHKEYLISTS LT-FORM))))
(COND (DO-LIST
(*THROW 'CD-P (ANALYZE-ROLEMERGE DO-LIST LT-FORM)) )) ) ))
(PUSH 'JUNCT-ANALYSIS-LIST AL-VARS)
(DO ((ARGTAIL (ROLELINKS (CONCEPT-BODY LT-FORM)) (CDR ARGTAIL))
(ALPHATAIL ALPHABET (CDR ALPHATAIL))
(JUNCT-MATRIX) (JUNCT-EXPR) (JUNCT-PATHKEYLISTS)
(NORML-JUNCT-LIST) (JUNCT-ANALYSIS-LIST) )
((NULL ARGTAIL)
(FIX-AL JUNCT-ANALYSIS-LIST)
(SETQ NORML-JUNCT-LIST (ORDER-JUNCTS (CULL-EQS NORML-JUNCT-LIST)
JUNCT-ANALYSIS-LIST ) )
(LIST* (IMPLODE (NCONC (EXPLODE 'CNCT*)
(NCONS (PREVIOUS-LETTER (CAR ALPHATAIL))) ))
(PFC-CONCEPT (CONCEPT-BODY LT-FORM))
NORML-JUNCT-LIST ) )
(SETQ JUNCT-MATRIX (ARGUMENT (CAR ARGTAIL))
JUNCT-EXPR
(COND ((#.(ISA-OF:LT . λ-EXPR) LT-FORM)
(SETQ JUNCT-PATHKEYLISTS
(ORDER-PATHKEYLISTS
(SELECT&SHORTEN (CAR ALPHATAIL)
(LT-PATHKEYLISTS LT-FORM)
JUNCT-MATRIX ) ) )
(COND ((AND (EQ 'ATOMICPROPO (LT-TYPE JUNCT-MATRIX))
(ATOM-CONVERTIBLE JUNCT-PATHKEYLISTS
JUNCT-MATRIX ) )
(PFC-CONCEPT JUNCT-MATRIX) )
(T (MAKE-LT-λ-EXPR
λ-PREFIX (MAKE-LT-λ-PREFIX
PATHKEYLISTS JUNCT-PATHKEYLISTS )
λ-SCOPE JUNCT-MATRIX )) ) )
(T JUNCT-MATRIX) ) )
(ENDADD (NRML-ANL-YZE JUNCT-EXPR AL-VARS) NORML-JUNCT-LIST) ) ) )
(⊃-PROPO
(*CATCH 'CD-P
(COND ((#.(ISA-OF:LT . λ-EXPR) LT-FORM)
(LET ((DO-LIST (MERGED-PKLS (LT-PATHKEYLISTS LT-FORM))))
(COND (DO-LIST
(*THROW 'CD-P (ANALYZE-ROLEMERGE DO-LIST LT-FORM)) )) ) ))
(LET* ((ANTE-MATRIX (ANTECEDENT (CONCEPT-BODY LT-FORM)))
(ANTE-EXPR
(COND ((#.(ISA-OF:LT . λ-EXPR) LT-FORM)
(LET ((NEWPATHKEYLISTS
(ORDER-PATHKEYLISTS
(SELECT&SHORTEN 'A (LT-PATHKEYLISTS LT-FORM)
ANTE-MATRIX ) ) ))
(COND ((AND (EQ 'ATOMICPROPO (LT-TYPE ANTE-MATRIX))
(ATOM-CONVERTIBLE NEWPATHKEYLISTS
ANTE-MATRIX ) )
(PFC-CONCEPT ANTE-MATRIX) )
(T (MAKE-LT-λ-EXPR
λ-PREFIX (MAKE-LT-λ-PREFIX
PATHKEYLISTS NEWPATHKEYLISTS )
λ-SCOPE ANTE-MATRIX )) ) ) )
(T ANTE-MATRIX) ) )
(CONSE-MATRIX (CONSEQUENT (CONCEPT-BODY LT-FORM)))
(CONSE-EXPR
(COND ((#.(ISA-OF:LT . λ-EXPR) LT-FORM)
(LET ((NEWPATHKEYLISTS
(ORDER-PATHKEYLISTS
(SELECT&SHORTEN 'B (LT-PATHKEYLISTS LT-FORM)
CONSE-MATRIX ) ) ))
(COND ((AND (EQ 'ATOMICPROPO (LT-TYPE CONSE-MATRIX))
(ATOM-CONVERTIBLE NEWPATHKEYLISTS
CONSE-MATRIX ) )
(PFC-CONCEPT CONSE-MATRIX) )
(T (MAKE-LT-λ-EXPR
λ-PREFIX (MAKE-LT-λ-PREFIX
PATHKEYLISTS NEWPATHKEYLISTS )
λ-SCOPE CONSE-MATRIX )) ) ) )
(T CONSE-MATRIX) ) ) )
(LIST 'CNCT*B '⊃ (NRML-ANL-YZE ANTE-EXPR AL-VARS)
(NRML-ANL-YZE CONSE-EXPR AL-VARS) ) ) ) )
(FIXNUM-VECTOR
(LET ((SIZE-LETTER (NTH (1- (LENGTH LT-FORM)) ALPHABET)))
(LIST* (IMPLODE (NCONC (EXPLODE 'VECT*) (NCONS SIZE-LETTER)))
LT-FORM ) ) )
(T (BREAK "ANALYZE-CMPD-CONCEPT - unrecognized form type")) ) )
(DEFUN NACC (LT-FORM &optional AL-VARS)
(NRML-ANL-YZE LT-FORM AL-VARS) )
(DEFMACRO GET-PK-POSITION (PATHKEY PKEYLISTS)
`(DO ((PKLISTAIL ,PKEYLISTS (CDR PKLISTAIL))
(TALLYTAIL ALPHABET (CDR TALLYTAIL)) (PATHKEY ,PATHKEY) )
((EQ PATHKEY (CAR (PATHKEYS (CAR PKLISTAIL)))) (CAR TALLYTAIL))
(OR PKLISTAIL (BREAK "GET-PK-POSITION - error")) ) )
(DEFMACRO GET-MERGEKEYS (MERGED-PKLS LT-λ-EXPR)
`(ORDER-PATHKEYLISTS
(DO ((OLDPKL-TAIL (LT-PATHKEYLISTS ,LT-λ-EXPR) (CDR OLDPKL-TAIL))
(MKEYLISTS) )
((NULL OLDPKL-TAIL) MKEYLISTS)
;; MKEYLISTS : ((<1-digit-merge-position-key> ... ) ... )
(COND ((MEMQ (CAR OLDPKL-TAIL) ,MERGED-PKLS)
;; if pathkeylist is rolemerged, then collect the
;; merge-position keys corresponding to its members.
(PUSH (ORDER-PATHKEYS
(MAPCAR #'(LAMBDA (OLDPKEY)
(GET-PK-POSITION OLDPKEY NEWPKEYLISTS) )
(PATHKEYS (CAR OLDPKL-TAIL)) ) )
MKEYLISTS ) )) ) ) )
(DEFMACRO EXPAND-MERGED-PKEYLISTS (MERGED-PKLS LT-λ-EXPR)
`(ORDER-PATHKEYLISTS
(DO ((OLDPKL-TAIL (LT-PATHKEYLISTS ,LT-λ-EXPR) (CDR OLDPKL-TAIL))
(NEWPKLISTPTR (NCONS NIL)) )
((NULL OLDPKL-TAIL) (CAR NEWPKLISTPTR))
(COND ((MEMQ (CAR OLDPKL-TAIL) ,MERGED-PKLS)
(LCONC (MAPCAR #'(LAMBDA (PATHKEY)
(LIST (λ-TERMSORT (CAR OLDPKL-TAIL))
PATHKEY ) )
(PATHKEYS (CAR OLDPKL-TAIL)) )
NEWPKLISTPTR ) )
((TCONC (COPYLIST (CAR OLDPKL-TAIL)) NEWPKLISTPTR)) ) ) ) )
;; no need to ORDER-PATHKEYS here, since each new pathkeylist
;; has just one member.
(DEFUN ANALYZE-ROLEMERGE (MERGED-PKLS LT-λ-EXPR)
(LET* ((NEWPKEYLISTS (ORDER-PATHKEYLISTS
(EXPAND-MERGED-PKEYLISTS MERGED-PKLS LT-λ-EXPR) ))
(MERGEKEYLISTS (GET-MERGEKEYS MERGED-PKLS LT-λ-EXPR))
(RLMRG-OP (DO ((MKL-TAIL (CDR MERGEKEYLISTS) (CDR MKL-TAIL))
(IMPLISTPTR (NCONS NIL)) )
((NULL MKL-TAIL)
(IMPLODE (NCONC (EXPLODE 'RLMRG*)
(CAR MERGEKEYLISTS)
(CAR IMPLISTPTR) )) )
(LCONC (CONS '+ (CAR MKL-TAIL)) IMPLISTPTR) ) )
(λ-SCOPE (LT-λ-SCOPE LT-λ-EXPR))
(NEWEXPR (COND ((AND (EQ 'ATOMICPROPO (LT-TYPE λ-SCOPE))
(ATOM-CONVERTIBLE NEWPKEYLISTS λ-SCOPE) )
(PFC-CONCEPT λ-SCOPE) )
((MAKE-LT-λ-EXPR
λ-PREFIX (MAKE-LT-λ-PREFIX PATHKEYLISTS NEWPKEYLISTS)
λ-SCOPE λ-SCOPE )) )) )
(LIST RLMRG-OP
(NRML-ANL-YZE NEWEXPR AL-VARS) ) ) )
(DEFUN ATOM-CONVERTIBLE (PATHKEYLISTS λ-SCOPE
&aux (PKL-LENGTH (LENGTH PATHKEYLISTS)) )
;; there are as many pathkeylists as coreroles, and as rolelinks;
(AND (= PKL-LENGTH (LENGTH (GET (PFC-CONCEPT λ-SCOPE) 'COREROLES)))
(= PKL-LENGTH (LENGTH (ROLELINKS λ-SCOPE)))
;; and each pathkeylist has just one member, which is EQ to the
;; proper pathkey-digit.
(DO ((PKL-TAIL PATHKEYLISTS (CDR PKL-TAIL))
(ALPHA-TAIL ALPHABET (CDR ALPHA-TAIL)) )
((NULL PKL-TAIL) T)
(COND ((AND (MEMQ (CAR ALPHA-TAIL) (PATHKEYS (CAR PKL-TAIL)))
(NULL (CDR (PATHKEYS (CAR PKL-TAIL)))) ))
((RETURN NIL)) ) ) ) )
(DEFUN ADJUST-λ-TERMSORT (PKEYLIST LT-FORM &aux PKEYSORT PKEYSORTS)
(MAPC #'(LAMBDA (PATHKEY)
(SETQ PKEYSORT (PATHKEY-SORT PATHKEY LT-FORM))
(COND ((NOT (MEMQ PKEYSORT PKEYSORTS))
(PUSH PKEYSORT PKEYSORTS) )) )
(PATHKEYS PKEYLIST) )
(SETF (λ-TERMSORT PKEYLIST) (COMMON-SUBSORT* PKEYSORTS))
PKEYLIST )
(DEFUN COMMON-SUBSORT* (SORTLIST) ;; (presupposes no duplicates in SORTLIST)
(COND ((NULL (CDR SORTLIST)) (CAR SORTLIST))
(T (DO ((COMMON-SS*? (COND ((SUPERSORT* (CAR SORTLIST) (CADR SORTLIST))
(CADR SORTLIST) )
((SUPERSORT* (CADR SORTLIST) (CAR SORTLIST))
(CAR SORTLIST) )
(T NIL) ))
(SORTAIL (CDR SORTLIST)) )
()
(COND ((NULL COMMON-SS*?) (RETURN NIL)))
A (SETF* SORTAIL (CDR -*-))
(COND ((NULL SORTAIL) (RETURN COMMON-SS*?))
((SUPERSORT* (CAR SORTAIL) COMMON-SS*?) (GO A))
((SUPERSORT* COMMON-SS*? (CAR SORTAIL))
(SETQ COMMON-SS*? (CAR SORTAIL))
(GO A) )
(T (RETURN NIL)) ) )) ) )
(DEFUN SUPERSORT* (SORT1 SORT2) ;; This relation is strict, i.e., asymmetric.
(*CATCH 'SS*
(COND ((AND (CONSP SORT1) (EQ '↑ (GETCHAR (CAR SORT1) 1))
(CONSP SORT2) (EQ (CAR SORT1) (CAR SORT2)) )
(*THROW 'SS* (SUPERSORT* (CDR SORT1) (CDR SORT2))) )
((NOT (AND (ATOM SORT1) (ATOM SORT2)))
(WRITE T "; Sort mismatch... "
T "; SORT1: " SORT1 " , SORT2: " SORT2 "."
(BREAK SUPERSORT*) ) ) )
(PROG (SS*-CANDIDATE CURRENT-SS)
(COND ((OR (EQ SORT1 SORT2) (EQ SORT2 'THING)) (RETURN NIL)))
(SETQ SS*-CANDIDATE (OR SORT1 (WRITE T "; SORT1 is null!"
(BREAK SUPERSORT*) )))
(SETQ CURRENT-SS (OR (GET SORT2 'SUPERSORT)
(WRITE T "; No supersort for " SORT2 "."
(BREAK SUPERSORT*) ) ))
A (COND ((EQ CURRENT-SS SS*-CANDIDATE) (RETURN T))
((EQ CURRENT-SS 'THING) (RETURN NIL)) )
(SETQ CURRENT-SS (OR (GET CURRENT-SS 'SUPERSORT)
(WRITE T "; No supersort for " CURRENT-SS "."
(BREAK SUPERSORT*) ) ))
(GO A) ) ) )
(DEFMACRO MAKE-↑-MARKER (NUMBER-ATOM)
`(COND ((= ,NUMBER-ATOM 1) '↑)
((> ,NUMBER-ATOM 1)
(SETQ *NOPOINT T) ;; assumes *NOPOINT is null to start with.
(PROG1 (IMPLODE (APPEND '(↑) (EXPLODE ,NUMBER-ATOM)))
(SETQ *NOPOINT NIL) ) )
(T (BREAK "MAKE-↑-MARKER - zero ↑-value!")) ) )
(DEFUN PATHKEY-SORT (PATHKEY LT-FORM)
(DO ((KEYLIST (EXPLODE PATHKEY) (CDR KEYLIST))
(NEW-CURRENTFORM LT-FORM)
(↑-TALLY 0)
(CURRENTFORM) (CURRENTYPE) (PFC-ROLESORTS) (BASE-ROLESORT) )
((NULL KEYLIST)
(*CATCH 'P-S-DO
(COND ((EQ CURRENTYPE 'FIXNUM-VECTOR) (*THROW 'P-S-DO 'NUMBER)))
(SETQ PFC-ROLESORTS (OR (GET (PFC-CONCEPT CURRENTFORM) 'ROLESORTS)
(WRITE T "; No rolesorts for concept "
(PFC-CONCEPT CURRENTFORM) "."
(BREAK PATHKEY-SORT) ) )
BASE-ROLESORT (OR (CDR (ASSQ (ROLEMARK NEW-CURRENTFORM)
PFC-ROLESORTS ))
(WRITE T "; No rolesort for role "
(ROLEMARK NEW-CURRENTFORM)
T "; of concept "
(PFC-CONCEPT CURRENTFORM) "."
(BREAK PATHKEY-SORT) ) ) )
(COND ((CONSP BASE-ROLESORT)
(SETQ ↑-TALLY (+ ↑-TALLY (GET-↑-TALLY (CAR BASE-ROLESORT)))
BASE-ROLESORT (CDR BASE-ROLESORT) ) ))
(COND ((> ↑-TALLY 0)
(CONS (MAKE-↑-MARKER ↑-TALLY) BASE-ROLESORT) )
(T BASE-ROLESORT) ) ) )
(SETQ CURRENTFORM NEW-CURRENTFORM)
A (SETQ CURRENTYPE (LT-TYPE CURRENTFORM))
(CASEQ CURRENTYPE
((ROLELINK λ-EXPR) (SETQ CURRENTFORM (CDR CURRENTFORM)) (GO A))
(↑-TERM (SETQ ↑-TALLY (+ ↑-TALLY (GET-↑-TALLY (↑↓-MARKER CURRENTFORM)))
CURRENTFORM (CDR CURRENTFORM) ) (GO A) ) )
;; "CDR" here is indifferent between the equivalent accessor
;; macros "ARGUMENT", "↑↓-MATRIX", and "λ-SCOPE".
(SETQ NEW-CURRENTFORM (TERM-SUBRANCH (CAR KEYLIST)
CURRENTYPE
CURRENTFORM )) ) )
(DEFUN GET-ROLELINK (PATHKEY LT-FORM)
(DO ((KEYLIST (EXPLODE PATHKEY) (CDR KEYLIST))
(CURRENTFORM LT-FORM)
(CURRENTYPE) )
((NULL KEYLIST) CURRENTFORM)
A (SETQ CURRENTYPE (LT-TYPE CURRENTFORM))
(COND ((MEMQ CURRENTYPE '(ROLELINK ↑-TERM λ-EXPR))
(SETQ CURRENTFORM (CDR CURRENTFORM)) (GO A) ))
;; "CDR" here is indifferent between the equivalent accessor
;; macros "ARGUMENT", "↑↓-MATRIX", and "λ-SCOPE".
(SETQ CURRENTFORM (TERM-SUBRANCH (CAR KEYLIST)
CURRENTYPE
CURRENTFORM )) ) )
(DEFMACRO Z-BASE-EQUIV (LETTER)
`(- (CAR (EXPLODEN ,LETTER)) 65.) )
(DEFMACRO ALPHA-NTH (ALPHAKEY LIST)
`(DO ((LISTAIL ,LIST (CDR LISTAIL))
(ALPHATAIL ALPHABET (CDR ALPHATAIL)) )
((EQ ,ALPHAKEY (CAR ALPHATAIL)) (CAR LISTAIL))
(OR ALPHATAIL (BREAK "ALPHA-NTH - off the end")) ) )
(DEFUN TERM-SUBRANCH (KEY TYPE LT-FORM)
(COND ((CASEQ TYPE
((ATOMICPROPO F-TERM CONJ-PROPO DISJ-PROPO ⊃-PROPO)
(ALPHA-NTH KEY (ROLELINKS LT-FORM)) )
(NEGPROPO (CAR (ROLELINKS LT-FORM)))
(QUANTIFIERFORM (CASEQ KEY
(A (#.(THE-OF:LT-QUANT . QSORTEXPR) LT-FORM))
(B (#.(THE-OF:LT-QUANT . SCOPE) LT-FORM)) ))
(FIXNUM-VECTOR (LIST 'FN-VECTOR-LINK KEY LT-FORM))
(T (BREAK "TERM-SUBRANCH - unrecognized form-type")) ))
(T (BREAK "TERM-SUBRANCH - missing sub-branch!")) ) )
(DEFMACRO ANY-IDENTICAL-ROLE-INSTANCES? (ROLELINK-LIST)
`(LET ((ANSWERLIST
(MAPCAN (FUNCTION (LAMBDA (IDENT-ROLEMARK)
(DO ((ROLNKTAIL ,ROLELINK-LIST (CDR ROLNKTAIL))
(TALLY 0) )
((NULL ROLNKTAIL)
(COND ((> TALLY 1) (NCONS IDENT-ROLEMARK))) )
(COND ((EQ (ROLEMARK (CAR ROLNKTAIL))
IDENT-ROLEMARK )
(SETQ TALLY (1+ TALLY)) )) ) ))
IDENT-ROLES ) ))
ANSWERLIST ) )
(DEFMACRO HAS-UNIQUE-ROLEMARKS (PFC-FORMULA)
`(LET ((IDENT-ROLES (GET (PFC-CONCEPT ,PFC-FORMULA) 'IDENTICAL-ROLES)))
(COND (IDENT-ROLES
(COND ((ANY-IDENTICAL-ROLE-INSTANCES? (ROLELINKS ,PFC-FORMULA))
NIL )
(T) ) )
(T) ) ) )
(DEFMACRO INDEX-TYPE (LT-TYPE LT-FORM)
`(CASEQ ,LT-TYPE
(SIMPLEFORM 'ATOM-INDEX)
((ATOMICPROPO F-TERM)
(COND ((HAS-UNIQUE-ROLEMARKS ,LT-FORM)
'REGULAR-INDEX )
(T 'ARBSORT-INDEX) ) )
((CONJ-PROPO DISJ-PROPO) 'ARBSORT-INDEX)
(T 'REGULAR-INDEX) ) )
(DEFUN COPYALLCONS (S-EXPR)
(COND ((ATOM S-EXPR) S-EXPR)
(T (CONS (COPYALLCONS (CAR S-EXPR)) (COPYALLCONS (CDR S-EXPR)))) ) )
(DEFUN COPY-1-1-PKLS (PATHKEYLISTS)
(MAPCAN #'(LAMBDA (PKEYLIST)
(COND ((AND (NULL (CDR (PATHKEYS PKEYLIST)))
(NOT (GETCHAR (CAR (PATHKEYS PKEYLIST)) 2)) )
(NCONS (COPYLIST PKEYLIST)))) )
PATHKEYLISTS ) )
(DEFUN LT-COPYALL (LT-FORM &aux SUBSTPAIRS TERMCOPIES SUBSTPAIR)
(LT-SUBST* LT-FORM) )
;; LT-COPYALL* uses the freevars TERMCOPIES and SUBSTPAIR.
(DEFUN LT-COPYALL* (LT-FORM)
(COND ((ATOM LT-FORM) LT-FORM)
((#.(ISA . λ-PAIR) LT-FORM)
(COND ((SETQ SUBSTPAIR (ASSQ LT-FORM TERMCOPIES))
(CDR SUBSTPAIR) )
(T (LET ((λ-PAIR-COPY (CONS 'λ (CDR LT-FORM))))
(PUSH (CONS LT-FORM λ-PAIR-COPY) TERMCOPIES)
λ-PAIR-COPY )) ) )
((HUNKP LT-FORM)
(COND ((SETQ SUBSTPAIR (ASSQ LT-FORM TERMCOPIES))
(CDR SUBSTPAIR) )
(T (LET ((HUNKCOPY (MAKHUNK (HUNKSIZE LT-FORM))))
(COND ((#.(ISA-OF:LT . QUANTIFIER) LT-FORM)
(PUSH (CONS LT-FORM HUNKCOPY) TERMCOPIES) ))
;; the first occurrence of a quantifierform is a proposition,
;; and is copied; subsequent occurrences of that same
;; quantifierform are individual terms playing the role of
;; variables, and are NOT copied, but reproduced (EQ).
(DO ((INDEX 0 (1+ INDEX))
(HUNKSIZE (HUNKSIZE LT-FORM)) )
((= INDEX HUNKSIZE) HUNKCOPY)
(RPLACX INDEX HUNKCOPY
(LT-COPYALL* (CXR INDEX LT-FORM)) ) ) )) ) )
(T (CONS (COND ((AND (HUNKP (CAR LT-FORM))
(SETQ SUBSTPAIR (ASSQ (CAR LT-FORM) TERMCOPIES)) )
(CDR SUBSTPAIR) )
(T (LT-COPYALL* (CAR LT-FORM))) )
(COND ((AND (HUNKP (CDR LT-FORM))
(SETQ SUBSTPAIR (ASSQ (CDR LT-FORM) TERMCOPIES)) )
(CDR SUBSTPAIR) )
(T (LT-COPYALL* (CDR LT-FORM))) ) )) ) )
;; LT-SUBST produces a modified copy of LT-FORM that preserves EQ-ness of
;; logical subexpressions, with the CDR of each SUBSTPAIR being substituted
;; for its CAR throughout the copy.
(DEFUN LT-SUBST (SUBSTPAIRS LT-FORM &aux TERMCOPIES SUBSTPAIR)
(LT-SUBST* LT-FORM) )
;; LT-SUBST* uses the freevars SUBSTPAIRS, TERMCOPIES, AND SUBSTPAIR.
(DEFUN LT-SUBST* (LT-FORM)
(*CATCH 'LT-S
(COND ((SETQ SUBSTPAIR (OR (ASSQ LT-FORM SUBSTPAIRS)
(ASSQ LT-FORM TERMCOPIES) ))
(*THROW 'LT-S (CDR SUBSTPAIR)) ))
(CASEQ (LT-TYPE LT-FORM)
((SIMPLEFORM PATT-VARIABLE) LT-FORM)
(λ-PAIR
(LET ((λ-PAIR-COPY (CONS 'λ (CDR LT-FORM))))
(PUSH (CONS LT-FORM λ-PAIR-COPY) TERMCOPIES)
λ-PAIR-COPY ) )
(QUANTIFIERFORM
(LET ((QUANTCOPY (MAKE-LT-QUANTIFIER
DETERMINER (LT-DETERMINER LT-FORM) )))
;; the first occurrence of a quantifierform is a proposition,
;; and is copied; subsequent occurrences of that same
;; quantifierform are individual terms playing the role of
;; variables, and are NOT copied, but reproduced (EQ).
(PUSH (CONS LT-FORM QUANTCOPY) TERMCOPIES)
(SETF (LT-QSORTEXPR QUANTCOPY)
(LT-SUBST* (LT-QSORTEXPR LT-FORM)) )
(SETF (LT-SCOPE QUANTCOPY) (LT-SUBST* (LT-SCOPE LT-FORM)))
(SETF (LT-DEPENDENCIES QUANTCOPY)
(MAPCAR #'(LAMBDA (DEP)
(LET ((DEP-PAIR (ASSQ DEP TERMCOPIES)))
(COND (DEP-PAIR (CDR DEP-PAIR))
(T (BREAK "LT-SUBST* - missing dependency!")) ) ) )
(LT-DEPENDENCIES LT-FORM) ) )
QUANTCOPY ) )
((ATOMICPROPO F-TERM CONJ-PROPO NEGPROPO DISJ-PROPO ⊃-PROPO)
(LET ((PFC-TERM-COPY
(MAKE-PFC-FORMULA
PFC-CONCEPT (PFC-CONCEPT LT-FORM)
ROLELINKS
(MAPCAR #'(LAMBDA (ROLINK)
(MAKE-ROLELINK
ROLEMARK (ROLEMARK ROLINK)
ARGUMENT (LT-SUBST* (ARGUMENT ROLINK)) ))
(ROLELINKS LT-FORM) ) ) ))
(PUSH (CONS LT-FORM PFC-TERM-COPY) TERMCOPIES)
PFC-TERM-COPY ) )
((λ-EXPR ↑-TERM ↓-TERM)
(LET ((λ↑↓-TERM-COPY
(CONS (CAR LT-FORM) (LT-SUBST* (CDR LT-FORM))) ))
(PUSH (CONS LT-FORM λ↑↓-TERM-COPY) TERMCOPIES)
λ↑↓-TERM-COPY ) )
(FIXNUM-VECTOR
(LET ((VECTOR-COPY (MAPCAR #'(LAMBDA (ELEMENT)
(LT-SUBST* ELEMENT) )
LT-FORM )))
(PUSH (CONS LT-FORM VECTOR-COPY) TERMCOPIES)
VECTOR-COPY ) )
(T (BREAK "LT-SUBST* - unrecognized lt-type.")) ) ) )
(DEFUN SELECT&SHORTEN (KEYDIGIT PATHKEYLISTS NEW-λ-SCOPE)
(MAPCAN
#'(LAMBDA (PKEYLIST)
(LET ((S&S-PATHKEYS
(ORDER-PATHKEYS
(MAPCAN #'(LAMBDA (PATHKEY)
(COND ((EQ KEYDIGIT (GETCHAR PATHKEY 1))
(NCONS (IMPLODE (CDR (EXPLODE PATHKEY)))) )) )
(PATHKEYS PKEYLIST) ) ) ))
(COND (S&S-PATHKEYS
(NCONS (ADJUST-λ-TERMSORT
(MAKE-PATHKEYLIST PATHKEYS S&S-PATHKEYS)
NEW-λ-SCOPE )) )) ) )
PATHKEYLISTS ) )
; The policy on ordering pathkeys and pathkeylists is to order them immediately
; upon construction, so that thereafter they can be assumed normally ordered.
; ORDER-PATHKEYLISTS should be used ONLY for its VALUE. Since it uses
; MACLISP's SORT function, its bare side-effect is incorrect.
(DEFUN ORDER-PATHKEYLISTS (PATHKEYLISTS)
(SORT PATHKEYLISTS #'(LAMBDA (PKL1 PKL2)
(ALPHALESSP (CAR (PATHKEYS PKL1))
(CAR (PATHKEYS PKL2)) ) )) )
(DEFUN ORDER-ROLELINKS (PFC-FORM)
;; PFC-FORM is the argument here, rather than the rolelinks to be ordered,
;; because we need to access the pfc-concept to get the roleorderindex.
(LET ((RO-INDEX (GET (PFC-CONCEPT PFC-FORM) 'ROLEORDERINDEX)))
(SORTCAR (ROLELINKS PFC-FORM) #'COMPARE-ROLEORDER) ) )
;; COMPARE-ROLEORDER uses the variable RO-INDEX freely.
(DEFUN COMPARE-ROLEORDER (ROLEMARK1 ROLEMARK2)
(MEMQ ROLEMARK2 (CDR (MEMQ ROLEMARK1 RO-INDEX))) )
(DEFUN CULL-EQS (LIST)
(MAP #'(LAMBDA (LISTAIL)
(SETF* (CDR LISTAIL) (DELQ (CAR LISTAIL) -*-)) )
LIST ) )
(DEFMACRO CONDENSE-RL-KEYLISTS (RL-KEYLISTS)
`(DO ((RL-KEYLISTAIL ,RL-KEYLISTS (CDR RL-KEYLISTAIL))
(DUPLISTAIL) )
((NULL RL-KEYLISTAIL) ,RL-KEYLISTS)
A (COND ((SETQ DUPLISTAIL
(SOME (CDR RL-KEYLISTAIL)
#'(LAMBDA (RL-KEYLIST)
(AND (EQ (CAR RL-KEYLIST) (CAAR RL-KEYLISTAIL))
(NOT (OR (EQ 'λ-EXPR (ATC-GET (CAR RL-KEYLIST)
'LT-TYPE ))
(ATC-GET (CAR RL-KEYLIST)
'COREROLES ) )) ) ) ) )
;; (argument-taking concepts all have a COREROLES property.)
(NCONC (CAR RL-KEYLISTAIL) (CDAR DUPLISTAIL))
(DELQ (CAR DUPLISTAIL) RL-KEYLISTAIL)
(GO A) )) ) )
; Here we rely on the fact that rolemerges are analyzed out before
; instantiations in ANALYZE-CMPD-CONCEPT, which implies that no argument-taking
; concept should be condensed out of an rl-keylist.
(DEFMACRO ATOM-QUASI-UNSUBST (INST-KEYS λ-SCOPE)
;; INST-KEYS: (<1-digit-pathkey> ... )
`(DO ((INSTKEYTAIL ,INST-KEYS (CDR INSTKEYTAIL))
(RL-KEYLISTSPTR (NCONS NIL))
(λ-SCOPE-ROLINKS (ROLELINKS ,λ-SCOPE))
(ARG-PKEYLISTS) (ARG-λ-SCOPE) (ARG-λ-EXPR) (NRML-ARG-λ-EXPR) )
((NULL INSTKEYTAIL) (CONDENSE-RL-KEYLISTS (CAR RL-KEYLISTSPTR)))
(SETQ ARG-λ-SCOPE (ARGUMENT (ALPHA-NTH (CAR INSTKEYTAIL) λ-SCOPE-ROLINKS)))
(SETQ ARG-PKEYLISTS
(COND (OLDPKEYLISTS
(ORDER-PATHKEYLISTS
(SELECT&SHORTEN (CAR INSTKEYTAIL)
OLDPKEYLISTS
ARG-λ-SCOPE ) ) )) )
(SETQ ARG-λ-EXPR
(COND ((OR (NULL ARG-PKEYLISTS)
(EQ (LT-TYPE ARG-λ-SCOPE) 'SIMPLEFORM) )
ARG-λ-SCOPE )
((AND (MEMQ (LT-TYPE ARG-λ-SCOPE) '(ATOMICPROPO F-TERM))
(ATOM-CONVERTIBLE ARG-PKEYLISTS ARG-λ-SCOPE) )
(PFC-CONCEPT ARG-λ-SCOPE) )
(T (MAKE-LT-λ-EXPR
λ-PREFIX (MAKE-LT-λ-PREFIX PATHKEYLISTS ARG-PKEYLISTS)
λ-SCOPE ARG-λ-SCOPE )) ) )
(SETQ NRML-ARG-λ-EXPR (NRML-ANL-YZE ARG-λ-EXPR AL-VARS))
(COND ((NOT (OR (EQ 'λ-EXPR (ATC-GET NRML-ARG-λ-EXPR 'LT-TYPE))
(ATC-GET NRML-ARG-λ-EXPR 'COREROLES ) ))
(SETF (ARGUMENT (ALPHA-NTH (CAR INSTKEYTAIL) λ-SCOPE-ROLINKS))
(COND ((ATOM ARG-λ-EXPR) ARG-λ-EXPR)
(T (ATC-GET NRML-ARG-λ-EXPR 'LT-FORMULA)) ) ) ))
(TCONC (LIST NRML-ARG-λ-EXPR (CAR INSTKEYTAIL)) RL-KEYLISTSPTR) ) )
(DEFUN ANALYZE-INSTANTIATION (INST-KEYS LT-FORM)
;; INST-KEYS: (<1-digit-pathkey> ... )
(LET* ((λ-SCOPE (CONCEPT-BODY LT-FORM))
(OLDPKEYLISTS (COND ((#.(ISA-OF:LT . λ-EXPR) LT-FORM)
(LT-PATHKEYLISTS LT-FORM))) )
(RL-KEYLISTS (ATOM-QUASI-UNSUBST INST-KEYS λ-SCOPE))
;; RL-KEYLISTS: ((<normalized component-concept> <pathkey> ...) ...)
(ADDPKEYLISTS (MAPCAR #'(LAMBDA (RL-KEYLIST)
(SETF* (CDR RL-KEYLIST)
(ADJUST-λ-TERMSORT
(CONS NIL
(ORDER-PATHKEYS -*-) )
λ-SCOPE ) ) )
RL-KEYLISTS ))
;; RL-KEYLISTS:
;; ((<normalized component-concept> <termsort> <pathkey> ...) ...)
(NEWPKEYLISTS (ORDER-PATHKEYLISTS
(NCONC ADDPKEYLISTS (COPY-1-1-PKLS OLDPKEYLISTS)) ))
(NEW-ATOMIC-EXPR
(COND ((ATOM-CONVERTIBLE NEWPKEYLISTS λ-SCOPE) (PFC-CONCEPT λ-SCOPE))
(T (MAKE-LT-λ-EXPR
λ-PREFIX (MAKE-LT-λ-PREFIX PATHKEYLISTS NEWPKEYLISTS)
λ-SCOPE λ-SCOPE )) ) )
(ARG-COMPONENTS (MAPCAR #'CAR RL-KEYLISTS))
(OP-KEYS (MAPCAR #'(LAMBDA (RL-KEYLIST)
(GET-PKL-POSITION (CDR RL-KEYLIST)
NEW-ATOMIC-EXPR ) )
RL-KEYLISTS ))
(INST-OP (IMPLODE (NCONC (EXPLODE 'INST*) OP-KEYS))) )
(LIST* INST-OP
(NRML-ANL-YZE NEW-ATOMIC-EXPR AL-VARS)
ARG-COMPONENTS ) ) )
(DEFUN λ-UNSUBST (LT-λ-EXPR &optional (COPYFLAG 'COPY)
&aux (λ-SCOPE (COND (COPYFLAG
(LT-COPYALL (LT-λ-SCOPE LT-λ-EXPR)) )
(T (LT-λ-SCOPE LT-λ-EXPR)) ))
ROLINK )
(MAPC #'(LAMBDA (PKEYLIST)
(LET* ((λ-TERMSORT (λ-TERMSORT PKEYLIST))
(λ-PAIR (CONS 'λ λ-TERMSORT))
(↑-λ-TERMSORTFLAG
(AND (CONSP λ-TERMSORT)
(EQ '↑ (GETCHAR (CAR λ-TERMSORT) 1 )) ) ) )
(MAPC #'(LAMBDA (PATHKEY)
(SETQ ROLINK (GET-ROLELINK PATHKEY λ-SCOPE))
(COND ((AND ↑-λ-TERMSORTFLAG
(EQ (LT-TYPE (ARGUMENT ROLINK)) '↓-TERM) )
(SETQ ROLINK (ARGUMENT ROLINK)) ))
(COND ((EQ 'FN-VECTOR-LINK (ROLEMARK ROLINK))
(SETF (NTH (Z-BASE-EQUIV (CADR ROLINK))
(CADDR ROLINK) )
λ-PAIR ) )
(T (SETF (ARGUMENT ROLINK)
(COND ((AND ↑-λ-TERMSORTFLAG
(NOT (EQ (LT-TYPE ROLINK)
'↓-TERM ))
(EQ (LT-TYPE λ-SCOPE)
'↑-TERM ) )
(MAKE-↑↓-TERM
↑↓-MARKER '↓
↑↓-MATRIX λ-PAIR ) )
(T λ-PAIR) ) ) ) ) )
(PATHKEYS PKEYLIST) ) ) )
(LT-PATHKEYLISTS LT-λ-EXPR) )
(COND (COPYFLAG
(MAKE-LT-λ-EXPR λ-PREFIX (LT-λ-PREFIX LT-λ-EXPR)
λ-SCOPE λ-SCOPE ) )
(T LT-λ-EXPR) ) )
(DEFMACRO CC-KEY-ROLINK-NUMBER (LT-FORM)
`(COND ((ATOM ,LT-FORM) (LENGTH (GET ,LT-FORM 'COREROLES)))
((LENGTH (LT-PATHKEYLISTS ,LT-FORM))) ) )
(DEFMACRO INITSTR= (TESTRING TARGETSTRING)
`(DO ((TESTRING ,TESTRING)
(TARGETSTRING ,TARGETSTRING)
(TESTCHAR (GETCHAR ,TESTRING 1))
(CHARINDEX 1 (1+ CHARINDEX)) )
((NULL TESTCHAR) T)
(COND ((EQ TESTCHAR (GETCHAR TARGETSTRING CHARINDEX)))
(T (RETURN NIL)) )
(SETQ TESTCHAR (GETCHAR TESTRING (1+ CHARINDEX))) ) )
; λ-INST-KEY returns a c-prefixed cc-op if CC-KEYLIST corresponds to a λ-expr.
(DEFUN λ-INST-KEY (CC-KEYLIST)
(COND ((AND (INITSTR= 'INST* (CAR CC-KEYLIST))
(LET* ((CC-OP-CHARS (EXPLODE (CAR CC-KEYLIST)))
(ARGCHARS (CDR (MEMQ '* CC-OP-CHARS))) )
(COND ((< (LENGTH ARGCHARS)
(CC-KEY-ROLINK-NUMBER (CADR CC-KEYLIST)) )
(IMPLODE (CONS 'C CC-OP-CHARS)) )) ) ))) )
(DEFUN RAISEATOM (ATOM &aux (PNAMEASCIIS (EXPLODEN ATOM)))
(COND ((↑-ASCII (CAR PNAMEASCIIS))
(COND ((NULL (CDR PNAMEASCIIS))
(SETF (CDR PNAMEASCIIS) (NCONS 50.)))
((2:9-ASCII (CADR PNAMEASCIIS))
(SETF* (CADR PNAMEASCIIS) (1+ -*-))
(OR (2:9-ASCII (CADR PNAMEASCIIS))
(BREAK "RAISEATOM - not enough numerals") ) )
(T (SETF* (CDR PNAMEASCIIS) (CONS 50. -*-))) ) )
(T (SETF* PNAMEASCIIS (CONS 94. -*-))) )
(IMPLODE PNAMEASCIIS) )
(DEFUN GET-↑-MARKER (ATOM &aux (PNAMEASCIIS (EXPLODEN ATOM)))
(OR (ATOM ATOM) (WRITE T "; ATOM non-atomic! => " ATOM (BREAK GET-↑-MARKER)))
(COND ((↑-ASCII (CAR PNAMEASCIIS))
(COND ((AND (CDR PNAMEASCIIS)
(2:9-ASCII (CADR PNAMEASCIIS)) )
(SETF* (CDDR PNAMEASCIIS) NIL) )
(T (SETF* (CDR PNAMEASCIIS) NIL)) )
(IMPLODE PNAMEASCIIS) )
(T NIL) ) )
(DEFUN GET-↑-TALLY (↑-ATOM)
(*CATCH 'G↑T
(COND ((NOT (AND (ATOM ↑-ATOM) (EQ '↑ (GETCHAR ↑-ATOM 1))))
(WRITE T "; Bad argument: " ↑-ATOM (BREAK GET-↑-TALLY)) ))
(LET ((ASCII2 (GETCHARN ↑-ATOM 2)))
(COND ((OR (ZEROP ASCII2) (NOT (NUMERAL-ASCII ASCII2)))
(*THROW 'G↑T 1) )
(T (LET ((ASCII3 (GETCHARN ↑-ATOM 3)))
(COND ((OR (ZEROP ASCII3) (NOT (NUMERAL-ASCII ASCII3)))
(*THROW 'G↑T (- ASCII2 48.)) )) )) ) )
(LET ((ASCIIS (EXPLODEN ↑-ATOM)))
(DO ((ASCII-TAIL ASCIIS (CDR ASCII-TAIL)))
((NULL ASCII-TAIL) NIL)
(COND ((AND (CDR ASCII-TAIL)
(NOT (NUMERAL-ASCII (CADR ASCII-TAIL))) )
(RPLACD ASCII-TAIL NIL)
(RETURN T) )) )
(DO ((NUMASCII-TAIL (NREVERSE (CDR ASCIIS)) (CDR NUMASCII-TAIL))
(TALLY 0)
(TENS-FACTOR 1 (* TENS-FACTOR 10.)) )
((NULL NUMASCII-TAIL) TALLY)
(SETQ TALLY (+ TALLY (* (- (CAR NUMASCII-TAIL) 48) TENS-FACTOR))) ))))
(DEFUN LOWER-↑-ATOM (ATOM &aux (PNAMEASCIIS (EXPLODEN ATOM)))
(COND ((↑-ASCII (CAR PNAMEASCIIS))
(COND ((CADR PNAMEASCIIS)
(COND ((2:9-ASCII (CADR PNAMEASCIIS))
(SETF* (CADR PNAMEASCIIS) (1- -*-))
(OR (2:9-ASCII (CADR PNAMEASCIIS))
(SETF* (CDR PNAMEASCIIS) (CDDR -*-)) ) )
((SETF* PNAMEASCIIS (CDR -*-))) ) )
((SETF* PNAMEASCIIS (CDR -*-))) ) )
((BREAK "LOWER-↑-ATOM - ATOM not an ↑-atom!")) )
(IMPLODE PNAMEASCIIS) )
(DEFUN LOWER-λ-TERMSORTS (PATHKEYLISTS)
(MAPC #'(LAMBDA (PKEYLIST)
(LET ((TERMSORT (λ-TERMSORT PKEYLIST)))
(OR (AND (CONSP TERMSORT)
(EQ '↑ (GETCHAR (CAR TERMSORT) 1)) )
(BREAK "LOWER-λ-TERMSORT - improper ↑-λ-termsort.") )
(COND ((EQ '↑ (CAR TERMSORT))
(SETF* (λ-TERMSORT PKEYLIST) (CDR -*-)) )
(T (SETF* (CAR TERMSORT) (LOWER-↑-ATOM -*-))) ) ) )
PATHKEYLISTS ) )
(DEFUN RAISE-λ-TERMSORTS (PATHKEYLISTS)
(MAPC #'(LAMBDA (PKEYLIST)
(LET ((TERMSORT (λ-TERMSORT PKEYLIST)))
(COND ((ATOM TERMSORT)
(SETF* (λ-TERMSORT PKEYLIST) (CONS '↑ -*-)) )
((EQ '↑ (GETCHAR (CAR TERMSORT) 1))
(SETF* (CAR TERMSORT) (RAISEATOM -*-)) )
(T (BREAK "RAISE-λ-TERMSORT - improper λ-termsort.")) ) ) )
PATHKEYLISTS ) )
(DEFUN RAISE↑-TERM (↑-TERM &aux (↑-MARKASCIIS (EXPLODEN (↑↓-MARKER ↑-TERM))))
(COND ((CDR ↑-MARKASCIIS)
(SETF* (CADR ↑-MARKASCIIS) (1+ -*-))
(OR (2:9-ASCII (CADR ↑-MARKASCIIS))
(BREAK "RAISE↑-TERM - not enough numerals") ) )
((SETF* (CDR ↑-MARKASCIIS) (CONS 50. -*-))) )
(MAKE-↑↓-TERM ↑↓-MARKER (IMPLODE ↑-MARKASCIIS)
↑↓-MATRIX (↑↓-MATRIX ↑-TERM) ) )
(DEFMACRO NEXTLETTER (LETTER)
`(OR (CADR (MEMQ ,LETTER ALPHABET))
(BREAK "NEXTLETTER - off the end") ) )
(DEFUN KEYNUMBER (LETTER)
(DO ((ALPHATAIL ALPHABET (CDR ALPHATAIL))
(TALLY 1 (1+ TALLY)) )
((EQ LETTER (CAR ALPHATAIL)) TALLY) ) )
(SETQ |cc-op: | '|cc-op: | |=>| '|=>| | .| '| .| | | '| | | ;| '| ;|)
(SETQ V 'V C 'C | | '| | | - | '| - | )
;; LISTCOMPS uses the variable CURRENTPOS freely.
(DEFMACRO LISTCOMPS (COMPLIST)
`(DO ((CC-COMPTAIL ,COMPLIST (CDR CC-COMPTAIL))
(COMPNUM 1 (1+ COMPNUM)) )
((NULL CC-COMPTAIL) T)
(SETQ CURRENTPOS 1)
(WRITE T (POSPRINC COMPNUM | |))
(COND ((ATOM (CAR CC-COMPTAIL))
(WRITE (CAR CC-COMPTAIL)) )
(T (DISPLAY (CAR CC-COMPTAIL) CURRENTPOS)) ) ) )
(DEFMACRO EXPOUND-ANALYSIS-MODULE-1 (MODULE)
`(CASEQ VERBOSITY
((V VERBOSE)
(WRITE T "The resulting normalized concept-formula is represented externally as: "
T (DISPLAY (CAR ,MODULE))
T "The concept thus represented has been analyzed as follows:"
T "Concept-construction operator: " (CADR ,MODULE) | ;|
T "Component concepts: " )
(LISTCOMPS (CDDR ,MODULE))
(WRITE | .|) )
((C CONCISE)
(WRITE T (DISPLAY (CAR ,MODULE)) | | |=>|
T |cc-op: | (CADR ,MODULE) )
(LISTCOMPS (CDDR ,MODULE))
(WRITE | .|) ) ) )
;; POSPRINC uses the variable CURRENTPOS freely.
(DEFUN POSPRINC (&rest EXPRS
&aux (EXPRS-LENGTH (APPLY #'PLUS (MAPCAR #'FLATC EXPRS))) )
(OR (> 81. EXPRS-LENGTH) (BREAK "POSPRINC - EXPRS too long for 1 line."))
(SETQ CURRENTPOS (+ CURRENTPOS EXPRS-LENGTH))
(COND ((> 82. CURRENTPOS) (MAPC #'PRINC EXPRS))
(T (SETQ CURRENTPOS (1+ EXPRS-LENGTH)) (TERPRI) (MAPC #'PRINC EXPRS)) ) )
(DEFUN ANALYZE&EXPOUND (CC-CONCEPT &optional (VERBOSITY 'V)
&aux (CURRENTPOS 1) ANALYSIS-LIST )
(NRML-ANL-YZE CC-CONCEPT (NCONS 'ANALYSIS-LIST))
(FIX-AL ANALYSIS-LIST)
;; ANALYSIS-LIST :
;; ((<normalized-concept-expr> <cc-op> <component-concept-expr> ... ) ... )
(EXPOUND-ANALYSIS-MODULE-1 (CAR ANALYSIS-LIST))
(MAPC #'EXPOUND-ANALYSIS-MODULE-2 (CDR ANALYSIS-LIST))
(CASEQ VERBOSITY
((V VERBOSE)
(WRITE T "This finishes the analysis of "
T (DISPLAY (CAAR ANALYSIS-LIST)) | .|) )
((C CONCISE)
(WRITE T (DISPLAY (CAAR ANALYSIS-LIST)) " - analysis finished.") ) ) )
(DEFUN A&E (CC-CONCEPT &optional (VERBOSITY 'V))
(ANALYZE&EXPOUND CC-CONCEPT VERBOSITY) )
; FIX-AL accesses the global variable YHπ-FLAG.
(DEFUN FIX-AL (ANALYSIS-LIST)
; ANALYSIS-MODULE: (<cmpd-lt-form-genl-plist> <cc-index-key> ... )
; or (<compound lt-formula> <cc-index-key> ... )
(MAPC #'(LAMBDA (ANALYSIS-MODULE)
(MAP #'(LAMBDA (CC-LINKS)
(COND ((AND (CONSP (CAR CC-LINKS))
(EQ '*CC-PLIST* (CAAR CC-LINKS)) )
(SETF* (CAR CC-LINKS)
(GET -*- 'LT-FORMULA) ) )
((AND (ATOM (CAR CC-LINKS))
(LET ((LT-TYPE (ATC-GET (CAR CC-LINKS) 'LT-TYPE )))
(AND LT-TYPE
(NOT (EQ LT-TYPE 'SIMPLEFORM)) ) ) )
(SETF* (CAR CC-LINKS)
(π-GET -*- 'LT-FORMULA) ) ) ) )
ANALYSIS-MODULE ) )
ANALYSIS-LIST )
ANALYSIS-LIST )
(DEFUN EXPOUND-ANALYSIS-MODULE-2 (MODULE)
(CASEQ VERBOSITY
((V VERBOSE)
(WRITE T (DISPLAY (CAR MODULE)) T "has, in turn, been analyzed as follows:"
T "Concept-construction operator: " (CADR MODULE) | ;|
T "Component concepts: " )
(LISTCOMPS (CDDR MODULE))
(WRITE | .|) )
((C CONCISE)
(WRITE T (DISPLAY (CAR MODULE)) | | |=>|
T |cc-op: | (CADR MODULE) )
(LISTCOMPS (CDDR MODULE))
(WRITE | .|) ) ) )
;((EQ (TYPEP X) 'STRING) `(PRINC ,X)) ;; This doesn't work in our maclisp.
; (ATOM X) is true of strings, and (TYPEP X) yields SYMBOL.
; STRINGP could be defined as follows, but that would be excessively wasteful
; of conses, since most of the strings tested will be quite long.
;(DEFUN STRINGP (FORM)
; (AND (ATOM FORM) (EQ '/" (CAR (EXPLODE FORM)))) )
;; The variables CURRENTNODE and CURRENT-NODE-PATH are bound by EXPLORE-DNET
;; and used freely by several of the subsidiary DNET functions.
;; CURRENT-NODE-PATH: ({<leaf-node>} {<link-node>} ... {<*TOP*-link-node>})
;; i.e., a PUSHed list of successive "currentnodes", in reverse order.
;; CURRENTNODE: maintained EQ to (CAR CURRENT-NODE-PATH).
(DEFUN EXPLORE-DNET (&optional INITIAL-KEYPATH (DNET *CONCEPTS*)
&aux (CURRENT-NODE-PATH (NCONS DNET)) )
(PROG (CURRENTNODE COMMAND)
(SETQ CURRENTNODE (TRAVERSE-LINKS DNET INITIAL-KEYPATH))
A (SETQ COMMAND (GET-XPDN-COMMAND))
(CASEQ (COND ((SYMBOLP COMMAND) COMMAND)
((AND (CONSP COMMAND) (SYMBOLP (CAR COMMAND)))
(CAR COMMAND) )
(T (WRITE T " - improper command -- please try again ...")
(GO A) ) )
(CP (DISPLAY-KEYPATH CURRENT-NODE-PATH))
(CN (DISPLAY-NODE CURRENTNODE))
((CPN PN) (DISPLAY-KEYPATH CURRENT-NODE-PATH)
(DISPLAY-NODE CURRENTNODE) )
(XP (COND ((OR (ATOM COMMAND) (NULL (CDR COMMAND)))
;; missing argument defaults to 1.
(EXTEND-CURRENT-KEYPATH (NCONS 1)) )
(T (EXTEND-CURRENT-KEYPATH (CDR COMMAND))) ))
(SP (COND ((OR (ATOM COMMAND) (NULL (CDR COMMAND)))
;; missing argument defaults to 1.
(SHORTEN-CURRENT-NODEPATH 1) )
(T (SHORTEN-CURRENT-NODEPATH (CADR COMMAND))) ))
(CLL (COUNT-LINKS&LEAVES CURRENTNODE))
((PPV PPL) (OR (CONSP COMMAND) (SETF* COMMAND (NCONS -*-)))
(PRINT-PROPERTIES COMMAND) )
((Q QUIT EXIT) (RETURN "done"))
((? HELP) (XPDN-HELP (COND ((ATOM COMMAND) NIL)
(T (CDR COMMAND)) )))
(T (WRITE T " - unrecognized command -- please try again ...")) )
(GO A) ) )
(DEFUN XPDN (&optional INITIAL-KEYPATH (DNET *CONCEPTS*))
(EXPLORE-DNET INITIAL-KEYPATH DNET) )
(DEFUN GET-XPDN-COMMAND ()
(WRITE T '**)
(READ) )
(*DEFUN (ISA . LEAF-NODE) (NODE)
(OR (ATOM (LEAF-UNIT NODE))
(EQ '*CC-PLIST* (CAR (LEAF-PLIST NODE))) ) )
(*DEFUN (ISA . CC-OP) (ATOM)
(LET ((BASE-OP (GET-BASE-OP ATOM)))
(MEMQ BASE-OP '(INST ADVB QUANT CNCT RLMRG VECT)) ) )
;; TRAVERSE-LINKS sets the freevar CURRENT-NODE-PATH
(DEFUN TRAVERSE-LINKS (START-NODE KEYS)
(DO ((INDEX-KEYS KEYS (COND ((EQ '* (CAR INDEX-KEYS)) INDEX-KEYS)
(T (CDR INDEX-KEYS)) ))
(NEW-CURRENTNODE START-NODE)
(CURRENTKEY) (PATH-ADDITION) )
((NULL INDEX-KEYS) (ADDCONC PATH-ADDITION CURRENT-NODE-PATH)
NEW-CURRENTNODE )
(SETQ CURRENTKEY (CAR INDEX-KEYS))
;; check for special termination conditions.
(COND ((#.(ISA . LEAF-NODE) NEW-CURRENTNODE)
(COND ((EQ '* CURRENTKEY)
(ADDCONC PATH-ADDITION CURRENT-NODE-PATH)
(RETURN NEW-CURRENTNODE) )
(T (WRITE T
" - at leaf-node, but still have more keys specified!"
" -- please try again ..." )
(RETURN START-NODE) ) ) )
((AND (EQ '* CURRENTKEY) (< 1 (LENGTH (LINK-A-LIST NEW-CURRENTNODE))))
(COND ((EQ NEW-CURRENTNODE START-NODE)
(WRITE T
"multiple keys currently available - keypath unchanged." ) ))
(ADDCONC PATH-ADDITION CURRENT-NODE-PATH)
(RETURN NEW-CURRENTNODE) ) )
(SETQ NEW-CURRENTNODE (CASEQ (TYPEP CURRENTKEY)
(FIXNUM
(COND ((NTH (1- CURRENTKEY)
(LINK-A-LIST NEW-CURRENTNODE) ))
(T (WRITE T
" - there is no a-list entry for key: "
CURRENTKEY " -- please try again ..." )
(RETURN START-NODE) ) ) )
(SYMBOL
(COND ((EQ '* CURRENTKEY)
(CAR (LINK-A-LIST NEW-CURRENTNODE)) )
((ASSQ CURRENTKEY (LINK-A-LIST NEW-CURRENTNODE)))
(T (WRITE T
" - there is no a-list entry for key: "
CURRENTKEY " -- please try again ..." )
(RETURN START-NODE) ) ) )
(T (BREAK "TRAVERSE-LINKS - unacceptable key")) ))
(PUSH NEW-CURRENTNODE PATH-ADDITION) ) )
(DEFUN DISPLAY-KEYPATH (NODE-PATH &aux (CURRENTPOS 1))
;; NODE-PATH: ({<leaf-node>} {<link-node>} ... {<*TOP*-link-node>})
;; i.e., a PUSHed list of successive "currentnodes", in reverse order,
;; whose length is 1 greater than the displayed list of node-keys.
(COND ((NULL (CDR NODE-PATH)) (WRITE T " - keypath currently empty -"))
(T (POSPRINC "Current Keypath:")
(DO ((DPYLIST (CDR (REVERSE NODE-PATH)) (CDR DPYLIST))
(KEYNUM 0 (1+ KEYNUM)) (KEY) )
((NULL DPYLIST) T)
(SETQ KEY (LINK-KEY (CAR DPYLIST)))
(COND ((AND (ATOM KEY)
(OR (EQ (ATC-GET KEY 'LT-TYPE)
'SIMPLEFORM )
(#.(ISA . CC-OP) KEY) ) )
;; i.e., if KEY represents a simple lt-form or a cc-op
(COND ((< CURRENTPOS 76.) (POSPRINC | |)))
(POSPRINC KEYNUM | | KEY) )
(T (SETQ CURRENTPOS 1)
(WRITE T (POSPRINC KEYNUM | |)
(DISPLAY (ATC-GET KEY 'LT-FORMULA) CURRENTPOS) )) ) )) ) )
(DEFUN DISPLAY-NODE (NODE &aux (TALLY 1))
(COND ((AND (NULL (LINK-A-LIST NODE))
(EQ '*TOP* (LINK-KEY NODE)) )
(WRITE T " - discrimination net currently empty -") )
((#.(ISA . LEAF-NODE) NODE)
(WRITE T "Leaf-Node Formula:"
T (DISPLAY (ATC-GET (LEAF-PLIST NODE) 'LT-FORMULA)) ) )
(T (LET ((CURRENTPOS 1))
(TERPRI)
(POSPRINC "Available New Keys:")
(MAPC #'(LAMBDA (A-PAIR)
(LET ((KEY (CAR A-PAIR)))
(COND ((AND (ATOM KEY)
(OR (EQ (ATC-GET KEY 'LT-TYPE)
'SIMPLEFORM )
(#.(ISA . CC-OP) KEY) ) )
;; i.e., if KEY represents a simple lt-form or a cc-op
(COND ((< CURRENTPOS 76.) (POSPRINC | |)))
(POSPRINC TALLY | | KEY)
(SETF* TALLY (1+ -*-)) )
(T (SETQ CURRENTPOS 1)
(WRITE T (POSPRINC TALLY | |)
(DISPLAY (ATC-GET KEY 'LT-FORMULA)
CURRENTPOS ) )
(SETF* TALLY (1+ -*-)) ) ) ) )
(LINK-A-LIST NODE) ) )) ) )
;; EXTEND-CURRENT-KEYPATH uses the freevars CURRENTNODE and CURRENT-NODE-PATH.
(DEFUN EXTEND-CURRENT-KEYPATH (NEWKEYS &aux NEW-CURRENTNODE)
(COND ((NULL (LINK-A-LIST CURRENTNODE))
(WRITE T " - can't extend keypath; null a-list!") )
((#.(ISA . LEAF-NODE) CURRENTNODE)
(WRITE T " - can't extend keypath; already at a leaf-node.") )
(T (SETQ NEW-CURRENTNODE (TRAVERSE-LINKS CURRENTNODE NEWKEYS))
(COND ((NOT (EQ NEW-CURRENTNODE CURRENTNODE))
(SETQ CURRENTNODE NEW-CURRENTNODE)
(DISPLAY-KEYPATH CURRENT-NODE-PATH)
(DISPLAY-NODE CURRENTNODE) ) ) ) ) )
;; SHORTEN-CURRENT-NODEPATH accesses and sets
;; the freevars CURRENTNODE and CURRENT-NODE-PATH.
(DEFUN SHORTEN-CURRENT-NODEPATH (PARAM)
(*CATCH 'S-C-N
(COND ((AND (FIXP PARAM) (> PARAM 0))
(COND ((< PARAM (LENGTH CURRENT-NODE-PATH))
(REPEAT PARAM (POP CURRENT-NODE-PATH)) )
(T (WRITE T "SP-argument: " PARAM
" is too large -- please try again ..." )
(*THROW 'S-C-N NIL) ) ) )
((EQ '* PARAM)
(COND ((EQ '*TOP* (LINK-KEY (CAR CURRENT-NODE-PATH)))
(WRITE T " - already at root-node -- keypath unchanged.")
(*THROW 'S-C-N NIL) )
(T (POP CURRENT-NODE-PATH)) )
(DO ()
((< 1 (LENGTH (LINK-A-LIST (CAR CURRENT-NODE-PATH)))))
(COND ((EQ '*TOP* (LINK-KEY (CAR CURRENT-NODE-PATH)))
(WRITE T "now at root-node, but no multiple keys found.")
(RETURN T) ))
(POP CURRENT-NODE-PATH) ) )
((EQ '** PARAM)
(COND ((EQ '*TOP* (LINK-KEY (CAR CURRENT-NODE-PATH)))
(WRITE T " - already at root-node -- keypath unchanged.")
(*THROW 'S-C-N NIL) )
(T (SETQ CURRENT-NODE-PATH (LAST CURRENT-NODE-PATH))) ) )
(T (WRITE T "SP-argument: " PARAM
" is unacceptable -- please try again ..." )
(*THROW 'S-C-N NIL) ) )
(SETQ CURRENTNODE (CAR CURRENT-NODE-PATH))
(DISPLAY-KEYPATH CURRENT-NODE-PATH)
(DISPLAY-NODE CURRENTNODE) ) )
(DEFUN COUNT-LINKS&LEAVES (NODE)
(DO ((LINK-COUNTER 0)
(LEAF-COUNTER 0)
(UNCOUNTED-A-LISTS (NCONS (NCONS NODE)) (CDR UNCOUNTED-A-LISTS)) )
((NULL UNCOUNTED-A-LISTS) (WRITE T "Number of Link-nodes: " LINK-COUNTER
T "Number of Leaf-nodes: " LEAF-COUNTER ))
(MAPC #'(LAMBDA (NODE-TO-COUNT)
(COND ((#.(ISA . LEAF-NODE) NODE-TO-COUNT)
(SETF* LEAF-COUNTER (1+ -*-)))
(T (ENDADD (LINK-A-LIST NODE-TO-COUNT) UNCOUNTED-A-LISTS)
(SETF* LINK-COUNTER (1+ -*-)) ) ) )
(CAR UNCOUNTED-A-LISTS) ) ) )
(DEFUN PRINT-PROPERTIES (COMMAND &aux PROPNAME KEYTYPE NUMBER)
(*CATCH 'P-P
(COND ((CDR COMMAND)
(CASEQ (CAR COMMAND)
(PPV (SETQ PROPNAME (NTH 1 COMMAND)
KEYTYPE (NTH 2 COMMAND)
NUMBER (NTH 3 COMMAND) ))
(PPL (SETQ KEYTYPE (NTH 1 COMMAND)
NUMBER (NTH 2 COMMAND) )) ) ))
(COND ((NULL (CDR COMMAND))
(COND ((AND (EQ (CAR COMMAND) 'PPL)
(NOT (#.(ISA . LEAF-NODE) CURRENTNODE)))
(WRITE T
" - current node is not a leaf -- please try again..." )
(*THROW 'P-P NIL) )
((EQ (CAR COMMAND) 'PPV)
(WRITE " - missing property name -- please try again..." )
(*THROW 'P-P NIL) ) ) ))
(COND ((AND (EQ KEYTYPE 'C) (NULL (CDR CURRENT-NODE-PATH)))
(WRITE T " - keypath is currently empty -- please try again..")
(*THROW 'P-P NIL) )
((AND (EQ KEYTYPE 'A) (#.(ISA . LEAF-NODE) CURRENTNODE))
(WRITE T
" - no keys are available at a leaf-node -- please try again..." )
(*THROW 'P-P NIL) ))
(COND ((AND NUMBER
(NOT (AND (FIXP NUMBER)
(> NUMBER (CASEQ KEYTYPE (C -1) (A 0)
(T (WRITE T
" - improper keytype -- please try again..." )
(*THROW 'P-P NIL) ) ))
(< NUMBER (CASEQ KEYTYPE
(C (1- (LENGTH CURRENT-NODE-PATH)))
(A (1+ (LENGTH (LINK-A-LIST CURRENTNODE)))) )) )) )
(WRITE T " - bad keynumber -- please try again...")
(*THROW 'P-P NIL) ))
(LET ((PRINT-NODE (CASEQ KEYTYPE
(C (LINK-KEY (NTH (- (LENGTH CURRENT-NODE-PATH) 2 NUMBER)
CURRENT-NODE-PATH )))
(A (LINK-KEY (NTH (1- NUMBER) (LINK-A-LIST CURRENTNODE))))
(NIL (LEAF-PLIST CURRENTNODE)) )))
(CASEQ (CAR COMMAND)
(PPV (WRITE T (ATC-GET PRINT-NODE PROPNAME)))
(PPL (WRITE T (ATC-PLIST PRINT-NODE))) ) ) ) )
(DEFSTRUCT (HELP-TABLE-ENTRY (TYPE LIST))
COMMAND-KEY COMMAND-NAME ARG-SUMMARY 2ND-ARG-SUMMARY HELP-TEXT )
(SETQ XPDN-HELP-TABLE
'((CP "display Current keyPath" |no arguments|)
(CN "display Current Node" |no arguments|)
(CPN "display Current Path & Node" |no arguments|)
(XP "eXtend current keyPath" "argument(s): a list of key-indicators"
"key-indicator: a number, a key, or *" )
(SP "Shorten current keyPath" "argument: a number, *, or **")
(CLL "Count Links & Leaves" |no arguments|)
(PPV "Print Property Value" "argument list: (<propname> <keytype> <num>),"
"or (<propname>). <keytype>: C or A" )
(PPL "Print Property List" "arg list: [as for PPV, but sans <propname>]")
(Q "Quit" |no arguments|)
(? "Help" |no arguments|) ) )
(DEFUN XPDN-HELP (CMD-TAIL &aux (CURRENTPOS 1))
(COND ((NULL CMD-TAIL)
(SETQ CURRENTPOS 1)
(WRITE T (TAB 7) (POSPRINC "Command Summary:") (TAB 32.)
"Syntax -- <cmd> or (<cmd> {<arg>} ... {*{*}})" T T)
(MAPC #'(LAMBDA (ENTRY)
(SETQ CURRENTPOS 1)
(WRITE T (POSPRINC (COMMAND-KEY ENTRY))
(TAB 5)
(POSPRINC (COMMAND-NAME ENTRY))
(TAB 33.)
| - |
(POSPRINC (ARG-SUMMARY ENTRY)) )
(COND ((2ND-ARG-SUMMARY ENTRY)
(TAB 36.)
(POSPRINC (2ND-ARG-SUMMARY ENTRY)) )) )
XPDN-HELP-TABLE ) )
(T (LET ((ENTRY (ASSQ (CAR CMD-TAIL) XPDN-HELP-TABLE)))
(WRITE T (COMMAND-NAME ENTRY)
| - | (HELP-TEXT ENTRY) ) )) ) )